From mevenson at common-lisp.net Tue Mar 1 14:17:09 2011 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 01 Mar 2011 09:17:09 -0500 Subject: [armedbear-cvs] r13229 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Mar 1 09:17:08 2011 New Revision: 13229 Log: Remove non-existing THREAD-LOCK and THREAD-UNLOCK from autoloads. These symbols were first "neutered" with r12059 with non-working implementations in threads.lisp that were marked for removal with abcl-0.24.0. These symbols should not be present at all at this point. Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Tue Mar 1 09:17:08 2011 @@ -348,7 +348,7 @@ (export '(make-mailbox mailbox-send mailbox-empty-p mailbox-read mailbox-peek)) -(export '(make-thread-lock thread-lock thread-unlock with-thread-lock)) +(export '(make-thread-lock with-thread-lock)) (export '(make-mutex get-mutex release-mutex with-mutex)) From vvoutilainen at common-lisp.net Wed Mar 2 20:34:40 2011 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Wed, 02 Mar 2011 15:34:40 -0500 Subject: [armedbear-cvs] r13230 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Wed Mar 2 15:34:38 2011 New Revision: 13230 Log: Fix ticket #136: ABCL should allow DIRECTORY listings that don't follow symlinks, and/or provide a function for deleting a directory tree. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/src/org/armedbear/lisp/directory.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Wed Mar 2 15:34:38 2011 @@ -1475,10 +1475,14 @@ private static final Primitive LIST_DIRECTORY = new pf_list_directory(); private static class pf_list_directory extends Primitive { pf_list_directory() { - super("list-directory", PACKAGE_SYS, true, "directory"); + super("list-directory", PACKAGE_SYS, true, "directory &optional (resolve-symlinks t)"); } @Override public LispObject execute(LispObject arg) { + return execute(arg, T); + } + @Override + public LispObject execute(LispObject arg, LispObject arg2) { Pathname pathname = coerceToPathname(arg); if (pathname instanceof LogicalPathname) { pathname = LogicalPathname.translateLogicalPathname((LogicalPathname) pathname); @@ -1546,7 +1550,11 @@ if (file.isDirectory()) { p = Utilities.getDirectoryPathname(file); } else { - p = new Pathname(file.getCanonicalPath()); + if (arg2 != NIL) { + p = new Pathname(file.getCanonicalPath()); + } else { + p = new Pathname(file.getAbsolutePath()); + } } result = new Cons(p, result); } Modified: trunk/abcl/src/org/armedbear/lisp/directory.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/directory.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/directory.lisp Wed Mar 2 15:34:38 2011 @@ -45,7 +45,8 @@ (eq component :wild-inferiors)) (defun list-directories-with-wildcards (pathname - &optional (wild-inferiors-found nil)) + wild-inferiors-found + resolve-symlinks) (let* ((directory (pathname-directory pathname)) (first-wild-inferior (and (not wild-inferiors-found) (position-if #'wild-inferiors-p directory))) @@ -59,7 +60,7 @@ directory)) (newpath (make-pathname :directory non-wild :name nil :type nil :defaults pathname)) - (entries (list-directory newpath))) + (entries (list-directory newpath resolve-symlinks))) (if (not (or wild wild-inferiors-found)) entries (let ((inferior-entries (when (or wild-inferiors-found first-wild-inferior) entries))) @@ -86,11 +87,12 @@ (list-directories-with-wildcards (make-pathname :directory directory :defaults newpath) - (or first-wild-inferior wild-inferiors-found)))))) + (or first-wild-inferior wild-inferiors-found) + resolve-symlinks))))) entries)))))) -(defun directory (pathspec &key) +(defun directory (pathspec &key (resolve-symlinks t)) (let ((pathname (merge-pathnames pathspec))) (when (logical-pathname-p pathname) (setq pathname (translate-logical-pathname pathname))) @@ -104,7 +106,8 @@ (let ((device (pathname-device pathname))) (when device (setq namestring (concatenate 'string device ":" namestring))))) - (let ((entries (list-directories-with-wildcards namestring)) + (let ((entries (list-directories-with-wildcards + namestring nil resolve-symlinks)) (matching-entries ())) (dolist (entry entries) (cond ((file-directory-p entry) From vvoutilainen at common-lisp.net Wed Mar 2 20:46:32 2011 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Wed, 02 Mar 2011 15:46:32 -0500 Subject: [armedbear-cvs] r13231 - trunk/abcl Message-ID: Author: vvoutilainen Date: Wed Mar 2 15:46:31 2011 New Revision: 13231 Log: Update changelog for :resolve-symlinks and the -- command line argument. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Wed Mar 2 15:46:31 2011 @@ -1,3 +1,15 @@ +Version 0.25.0 +============== +svn://common-lisp.net/project/armedbear/svn/tags/0.25.0/abcl +(?? March 2011) + +Features +-------- + +* [svn r13230] Add :resolve-symlinks keyword argument for DIRECTORY. + +* [svn r13226] Support -- as a command line parameter for the REPL. + Version 0.24.0 ============== svn://common-lisp.net/project/armedbear/svn/tags/0.24.0/abcl From vvoutilainen at common-lisp.net Wed Mar 2 21:17:48 2011 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Wed, 02 Mar 2011 16:17:48 -0500 Subject: [armedbear-cvs] r13232 - trunk/abcl Message-ID: Author: vvoutilainen Date: Wed Mar 2 16:17:47 2011 New Revision: 13232 Log: Add the CHANGES done thus far targetting 0.25. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Wed Mar 2 16:17:47 2011 @@ -6,9 +6,66 @@ Features -------- -* [svn r13230] Add :resolve-symlinks keyword argument for DIRECTORY. +* Add :resolve-symlinks keyword argument for DIRECTORY. -* [svn r13226] Support -- as a command line parameter for the REPL. +* Support -- as a command line parameter for the REPL. + +* Preliminary support for Maven deployment. + +* Add an initargs cache for speedups in check-initargs. This should + make the initarg checking in CLOS quite a bit faster. + +* Incorporate output of 'svnversion' into LISP-IMPLEMENTATION-VERSION. + +* Ant target for generating Javadoc. + +Fixes +----- + +* [svn r13229] Remove non-existing THREAD-LOCK and THREAD-UNLOCK from autoloads. + +* [svn 13228] Fix incorrect elimination of named local functions + declared inline when they're actually reified in the flet/labels body. + +* [svn r13217] Forward-referenced classes work properly now. + +* [svn r13209] Add initarg checking to REINITIALIZE-INSTANCE. + +* [svn r13204] FINALIZE-INHERITANCE is (more) AMOP compatible. + +* [svn r13203] Create ATOMIC-DEFGENERIC macro, in order to eliminate + FMAKUNBOUND calls and the resulting windows where no function is bound to + symbols which are the most essential building blocks in CLOS/AMOP. + +* [svn r13200] Atomically swap generic functions into place of temporary + DEFUNs for all standard-class slot accessors. + Note: This addresses the recursive requirement to be able + to allocate objects and classes while changing the functions + used to create them. + +* [svn r13196] Provide more context regarding the reason of autoloading. + Note: This change *hugely* helps debugging. + +* [svn r13189] Fix MACROEXPAND-ALL autoloader which should be + loaded from 'format.lisp'. + +* [svn r13188] Fix DEFSTRUCT trying to generate accessors named NIL + +* [svn r13187] Fix #125: FASL reader should not convert symbol + case [Qi FASL loading issues]. + +* [svn r13185] Fix #119: Incorrect dynamic environment for + evaluation of :CLASS allocation slot initforms. + +* [svn r13182-r13184] Fix error printing issues. + +* [svn r13181] Increase autoload verbosity: include FASLs too + (not only Java classes). + +Changes +------- + +* Merge 'unsafe-p-removal' branch. Version 0.24.0 ============== From ehuelsmann at common-lisp.net Thu Mar 3 22:53:56 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 03 Mar 2011 17:53:56 -0500 Subject: [armedbear-cvs] r13233 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Mar 3 17:53:55 2011 New Revision: 13233 Log: Fix an UNSAFE-P-REMOVAL regression: inadvertently a statement in p2-logior wasn't deleted when it should have. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Mar 3 17:53:55 2011 @@ -4586,8 +4586,6 @@ ((compile-operand arg1 nil) (compile-operand arg2 :int) (maybe-emit-clear-values arg1 arg2))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) (emit-invokevirtual +lisp-object+ "LOGIOR" '(:int) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) From ehuelsmann at common-lisp.net Fri Mar 4 09:02:05 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 04 Mar 2011 04:02:05 -0500 Subject: [armedbear-cvs] r13234 - branches/0.25.x Message-ID: Author: ehuelsmann Date: Fri Mar 4 04:02:02 2011 New Revision: 13234 Log: Create 0.25 release branch. Added: branches/0.25.x/ - copied from r13233, /trunk/ From ehuelsmann at common-lisp.net Fri Mar 4 09:03:56 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 04 Mar 2011 04:03:56 -0500 Subject: [armedbear-cvs] r13235 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Mar 4 04:03:55 2011 New Revision: 13235 Log: Increase trunk version number, now that the 0.25 release branch has been created. Modified: trunk/abcl/src/org/armedbear/lisp/Version.java Modified: trunk/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Version.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Version.java Fri Mar 4 04:03:55 2011 @@ -41,7 +41,7 @@ { private Version() {} - static final String baseVersion = "0.25.0-dev"; + static final String baseVersion = "0.26.0-dev"; static void init() { try { From ehuelsmann at common-lisp.net Sat Mar 5 10:20:24 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 05 Mar 2011 05:20:24 -0500 Subject: [armedbear-cvs] r13236 - public_html Message-ID: Author: ehuelsmann Date: Sat Mar 5 05:20:18 2011 New Revision: 13236 Log: First draft for the 0.25 release notes page. Added: public_html/release-notes-0.25.shtml (contents, props changed) Added: public_html/release-notes-0.25.shtml ============================================================================== --- (empty file) +++ public_html/release-notes-0.25.shtml Sat Mar 5 05:20:18 2011 @@ -0,0 +1,72 @@ + + + + + ABCL - Release notes v0.25 + + + + + +
+

ABCL - Release notes for version 0.25

+
+ + + +
+ +

Most notable changes in ABCL 0.25

+ + +

Release notes for older releases.

+ +
+
New :resolve-symlinks keyword argument for DIRECTORY +
+
Passing NIL as the value for :resolve-symlinks prevents DIRECTORY from + returning truenames. +
+
LISP-IMPLEMENTATION-VERSION now includes Subversion revision info +
+
`svnversion` is used to retrieve the state of the working copy + being compiled from; the information is included in the value returned + by lisp-implementation-version. +
+
Object instantiation speedups +
+
A cache has been implemented to reduce the number of calculatoins + required when determining whether the keyword arguments to + MAKE-INSTANCE and REINITIALIZE-INSTANCE are valid. +
+
Compiler refactoring to prevent further stack inconsistency errors +
+
Due to earlier changes to the compiler and the overall structure, + the Java class verifier would detect 'stack inconsistency' issues + in some specific cases. The refactoring should put an end to that. + In the short term, however, this change could have a slightly destabilizing + effect. Tests have been carried out, but no issues were found so far. +
+
Instantiation of forward referenced classes +
+
When trying to instantiate a forward referenced class, the user + will not get a vague error anymore, but a clear error about + the situation. +
+
+ + + + +
+
+

Back to Common-lisp.net.

+ +
+ Valid XHTML 1.0 Strict +
+
$Id$
+
+ + From ehuelsmann at common-lisp.net Thu Mar 10 20:03:34 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 10 Mar 2011 15:03:34 -0500 Subject: [armedbear-cvs] r13237 - trunk/abcl Message-ID: Author: ehuelsmann Date: Thu Mar 10 15:03:31 2011 New Revision: 13237 Log: Set 0.25.0 release date in CHANGES. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Thu Mar 10 15:03:31 2011 @@ -1,7 +1,7 @@ Version 0.25.0 ============== svn://common-lisp.net/project/armedbear/svn/tags/0.25.0/abcl -(?? March 2011) +(10 March 2011) Features -------- From ehuelsmann at common-lisp.net Thu Mar 10 20:04:43 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 10 Mar 2011 15:04:43 -0500 Subject: [armedbear-cvs] r13238 - branches/0.25.x/abcl Message-ID: Author: ehuelsmann Date: Thu Mar 10 15:04:42 2011 New Revision: 13238 Log: Backport r13237 (update to CHANGES). Modified: branches/0.25.x/abcl/CHANGES Modified: branches/0.25.x/abcl/CHANGES ============================================================================== --- branches/0.25.x/abcl/CHANGES (original) +++ branches/0.25.x/abcl/CHANGES Thu Mar 10 15:04:42 2011 @@ -1,7 +1,7 @@ Version 0.25.0 ============== svn://common-lisp.net/project/armedbear/svn/tags/0.25.0/abcl -(?? March 2011) +(10 March 2011) Features -------- From ehuelsmann at common-lisp.net Thu Mar 10 20:06:13 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 10 Mar 2011 15:06:13 -0500 Subject: [armedbear-cvs] r13239 - in tags/0.25.0: . abcl abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Mar 10 15:06:13 2011 New Revision: 13239 Log: Tag 0.25.0. Added: tags/0.25.0/ - copied from r13236, /branches/0.25.x/ tags/0.25.0/abcl/CHANGES - copied unchanged from r13238, /branches/0.25.x/abcl/CHANGES Modified: tags/0.25.0/abcl/src/org/armedbear/lisp/Version.java Modified: tags/0.25.0/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- /branches/0.25.x/abcl/src/org/armedbear/lisp/Version.java (original) +++ tags/0.25.0/abcl/src/org/armedbear/lisp/Version.java Thu Mar 10 15:06:13 2011 @@ -41,7 +41,7 @@ { private Version() {} - static final String baseVersion = "0.25.0-dev"; + static final String baseVersion = "0.25.0"; static void init() { try { From ehuelsmann at common-lisp.net Thu Mar 10 20:07:50 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 10 Mar 2011 15:07:50 -0500 Subject: [armedbear-cvs] r13240 - branches/0.25.x/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Mar 10 15:07:49 2011 New Revision: 13240 Log: With 0.25.0 tagged, increase release branch version number. Modified: branches/0.25.x/abcl/src/org/armedbear/lisp/Version.java Modified: branches/0.25.x/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- branches/0.25.x/abcl/src/org/armedbear/lisp/Version.java (original) +++ branches/0.25.x/abcl/src/org/armedbear/lisp/Version.java Thu Mar 10 15:07:49 2011 @@ -41,7 +41,7 @@ { private Version() {} - static final String baseVersion = "0.25.0-dev"; + static final String baseVersion = "0.25.1-dev"; static void init() { try { From ehuelsmann at common-lisp.net Thu Mar 10 20:30:07 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 10 Mar 2011 15:30:07 -0500 Subject: [armedbear-cvs] r13241 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Mar 10 15:30:06 2011 New Revision: 13241 Log: Reduce the amount of code in our compiler by changing the way COMPILE-TEST-FORM works. Instead of returning a conditional jump, pass the labels around for the conditional jump. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Mar 10 15:30:06 2011 @@ -2379,6 +2379,7 @@ (> p2-test-numeric-comparison) (>= p2-test-numeric-comparison) (AND p2-test-and) + (OR p2-test-or) (ATOM p2-test-atom) (BIT-VECTOR-P p2-test-bit-vector-p) (CHAR= p2-test-char=) @@ -2421,40 +2422,74 @@ (initialize-p2-test-handlers) +(defknown negate-jump-condition (t) t) +(defun negate-jump-condition (jump-instruction) + (ecase jump-instruction + ('if_acmpeq 'if_acmpne) + ('if_acmpne 'if_acmpeq) + ('ifeq 'ifne) + ('ifne 'ifeq) + ('iflt 'ifge) + ('ifge 'iflt) + ('ifgt 'ifle) + ('ifle 'ifgt) + ('if_icmpeq 'if_icmpne) + ('if_icmpne 'if_icmpeq) + ('if_icmplt 'if_icmpge) + ('if_icmpge 'if_icmplt) + ('if_icmpgt 'if_icmple) + ('if_icmple 'if_icmpgt))) + +(defknown emit-test-jump (t t t) t) +(defun emit-test-jump (jump success-label failure-label) + (cond + (failure-label + (emit jump failure-label) + (when success-label + (emit 'goto success-label))) + (t + (emit (negate-jump-condition jump) success-label))) + t) + (defknown p2-test-predicate (t t) t) -(defun p2-test-predicate (form java-predicate) +(defun p2-test-predicate (form java-predicate success-label failure-label) (when (check-arg-count form 1) (let ((arg (%cadr form))) (compile-forms-and-maybe-emit-clear-values arg 'stack nil) (emit-invokevirtual +lisp-object+ java-predicate nil :boolean) - 'ifeq))) + (emit-test-jump 'ifeq success-label failure-label)))) -(declaim (ftype (function (t t) t) p2-test-instanceof-predicate)) -(defun p2-test-instanceof-predicate (form java-class) +(declaim (ftype (function (t t t t) t) p2-test-instanceof-predicate)) +(defun p2-test-instanceof-predicate (form java-class + success-label failure-label) (when (check-arg-count form 1) (let ((arg (%cadr form))) (compile-forms-and-maybe-emit-clear-values arg 'stack nil) (emit-instanceof java-class) - 'ifeq))) - -(defun p2-test-bit-vector-p (form) - (p2-test-instanceof-predicate form +lisp-abstract-bit-vector+)) + (emit-test-jump 'ifeq success-label failure-label)))) -(defun p2-test-characterp (form) - (p2-test-instanceof-predicate form +lisp-character+)) +(defun p2-test-bit-vector-p (form success-label failure-label) + (p2-test-instanceof-predicate form +lisp-abstract-bit-vector+ + success-label failure-label)) + +(defun p2-test-characterp (form success-label failure-label) + (p2-test-instanceof-predicate form +lisp-character+ + success-label failure-label)) ;; constantp form &optional environment => generalized-boolean -(defun p2-test-constantp (form) +(defun p2-test-constantp (form success-label failure-label) (when (= (length form) 2) (let ((arg (%cadr form))) (compile-forms-and-maybe-emit-clear-values arg 'stack nil) (emit-invokevirtual +lisp-object+ "constantp" nil :boolean) - 'ifeq))) + (emit-test-jump 'ifeq success-label failure-label)))) -(defun p2-test-endp (form) - (p2-test-predicate form "endp")) +(defun p2-test-endp (form success-label failure-label) + (p2-test-predicate form "endp" success-label failure-label)) -(defmacro p2-test-integer-predicate (form predicate &body instructions) +(defmacro p2-test-integer-predicate ((form predicate + success-label failure-label) + &body instructions) (let ((tmpform (gensym))) `(let ((,tmpform ,form)) (when (check-arg-count ,tmpform 1) @@ -2463,27 +2498,28 @@ (compile-forms-and-maybe-emit-clear-values arg 'stack :int) , at instructions) (t - (p2-test-predicate ,tmpform ,predicate)))))))) + (p2-test-predicate ,tmpform ,predicate + ,success-label ,failure-label)))))))) -(defun p2-test-evenp (form) - (p2-test-integer-predicate form "evenp" - (emit-push-constant-int 1) - (emit 'iand) - 'ifne)) - -(defun p2-test-oddp (form) - (p2-test-integer-predicate form "oddp" - (emit-push-constant-int 1) - (emit 'iand) - 'ifeq)) +(defun p2-test-evenp (form success-label failure-label) + (p2-test-integer-predicate (form "evenp" success-label failure-label) + (emit-push-constant-int 1) + (emit 'iand) + (emit-test-jump 'ifne success-label failure-label))) + +(defun p2-test-oddp (form success-label failure-label) + (p2-test-integer-predicate (form "oddp" success-label failure-label) + (emit-push-constant-int 1) + (emit 'iand) + (emit-test-jump 'ifeq success-label failure-label))) -(defun p2-test-floatp (form) - (p2-test-predicate form "floatp")) +(defun p2-test-floatp (form success-label failure-label) + (p2-test-predicate form "floatp" success-label failure-label)) -(defun p2-test-integerp (form) - (p2-test-predicate form "integerp")) +(defun p2-test-integerp (form success-label failure-label) + (p2-test-predicate form "integerp" success-label failure-label)) -(defun p2-test-listp (form) +(defun p2-test-listp (form success-label failure-label) (when (check-arg-count form 1) (let* ((arg (%cadr form)) (arg-type (derive-compiler-type arg))) @@ -2494,100 +2530,93 @@ (compile-forms-and-maybe-emit-clear-values arg nil nil) :alternate) (t - (p2-test-predicate form "listp")))))) + (p2-test-predicate form "listp" success-label failure-label)))))) -(defun p2-test-minusp (form) - (p2-test-integer-predicate form "minusp" 'ifge)) +(defun p2-test-minusp (form success-label failure-label) + (p2-test-integer-predicate (form "minusp" success-label failure-label) + (emit-test-jump 'ifge success-label failure-label))) -(defun p2-test-plusp (form) - (p2-test-integer-predicate form "plusp" 'ifle)) +(defun p2-test-plusp (form success-label failure-label) + (p2-test-integer-predicate (form "plusp" success-label failure-label) + (emit-test-jump 'ifle success-label failure-label))) -(defun p2-test-zerop (form) - (p2-test-integer-predicate form "zerop" 'ifne)) +(defun p2-test-zerop (form success-label failure-label) + (p2-test-integer-predicate (form "zerop" success-label failure-label) + (emit-test-jump 'ifne success-label failure-label))) -(defun p2-test-numberp (form) - (p2-test-predicate form "numberp")) +(defun p2-test-numberp (form success-label failure-label) + (p2-test-predicate form "numberp" success-label failure-label)) -(defun p2-test-packagep (form) - (p2-test-instanceof-predicate form +lisp-package+)) +(defun p2-test-packagep (form success-label failure-label) + (p2-test-instanceof-predicate form +lisp-package+ + success-label failure-label)) -(defun p2-test-rationalp (form) - (p2-test-predicate form "rationalp")) +(defun p2-test-rationalp (form success-label failure-label) + (p2-test-predicate form "rationalp" success-label failure-label)) -(defun p2-test-realp (form) - (p2-test-predicate form "realp")) +(defun p2-test-realp (form success-label failure-label) + (p2-test-predicate form "realp" success-label failure-label)) -(defun p2-test-special-operator-p (form) - (p2-test-predicate form "isSpecialOperator")) +(defun p2-test-special-operator-p (form success-label failure-label) + (p2-test-predicate form "isSpecialOperator" success-label failure-label)) -(defun p2-test-special-variable-p (form) - (p2-test-predicate form "isSpecialVariable")) +(defun p2-test-special-variable-p (form success-label failure-label) + (p2-test-predicate form "isSpecialVariable" success-label failure-label)) -(defun p2-test-symbolp (form) - (p2-test-instanceof-predicate form +lisp-symbol+)) +(defun p2-test-symbolp (form success-label failure-label) + (p2-test-instanceof-predicate form +lisp-symbol+ success-label failure-label)) -(defun p2-test-consp (form) - (p2-test-instanceof-predicate form +lisp-cons+)) +(defun p2-test-consp (form success-label failure-label) + (p2-test-instanceof-predicate form +lisp-cons+ success-label failure-label)) -(defun p2-test-atom (form) - (p2-test-instanceof-predicate form +lisp-cons+) - 'ifne) +(defun p2-test-atom (form success-label failure-label) + ;; The test below is a negative test, so, reverse the labels for failure and success + (p2-test-instanceof-predicate form +lisp-cons+ failure-label success-label)) -(defun p2-test-fixnump (form) - (p2-test-instanceof-predicate form +lisp-fixnum+)) +(defun p2-test-fixnump (form success-label failure-label) + (p2-test-instanceof-predicate form +lisp-fixnum+ success-label failure-label)) -(defun p2-test-stringp (form) - (p2-test-instanceof-predicate form +lisp-abstract-string+)) +(defun p2-test-stringp (form success-label failure-label) + (p2-test-instanceof-predicate form +lisp-abstract-string+ + success-label failure-label)) -(defun p2-test-vectorp (form) - (p2-test-instanceof-predicate form +lisp-abstract-vector+)) +(defun p2-test-vectorp (form success-label failure-label) + (p2-test-instanceof-predicate form +lisp-abstract-vector+ + success-label failure-label)) -(defun p2-test-simple-vector-p (form) - (p2-test-instanceof-predicate form +lisp-simple-vector+)) +(defun p2-test-simple-vector-p (form success-label failure-label) + (p2-test-instanceof-predicate form +lisp-simple-vector+ + success-label failure-label)) (defknown compile-test-form (t) t) -(defun compile-test-form (test-form) +(defun compile-test-form (test-form success-label failure-label) (when (consp test-form) (let* ((op (%car test-form)) (handler (p2-test-handler op)) - (result (and handler (funcall handler test-form)))) + (result (and handler (funcall handler test-form success-label + failure-label)))) (when result (return-from compile-test-form result)))) (cond ((eq test-form t) :consequent) - ((null test-form) - :alternate) ((eq (derive-compiler-type test-form) 'BOOLEAN) (compile-forms-and-maybe-emit-clear-values test-form 'stack :boolean) - 'ifeq) + (emit-test-jump 'ifeq success-label failure-label)) (t (compile-forms-and-maybe-emit-clear-values test-form 'stack nil) (emit-push-nil) - 'if_acmpeq))) + (emit-test-jump 'if_acmpeq success-label failure-label)))) -(defun p2-test-not/null (form) +(defun p2-test-not/null (form success-label failure-label) (when (check-arg-count form 1) (let* ((arg (%cadr form)) - (result (compile-test-form arg))) - (ecase result - ('if_acmpeq 'if_acmpne) - ('if_acmpne 'if_acmpeq) - ('ifeq 'ifne) - ('ifne 'ifeq) - ('iflt 'ifge) - ('ifge 'iflt) - ('ifgt 'ifle) - ('ifle 'ifgt) - ('if_icmpeq 'if_icmpne) - ('if_icmpne 'if_icmpeq) - ('if_icmplt 'if_icmpge) - ('if_icmpge 'if_icmplt) - ('if_icmpgt 'if_icmple) - ('if_icmple 'if_icmpgt) - (:alternate :consequent) - (:consequent :alternate))))) + (result (compile-test-form arg failure-label success-label))) + (case result + (:consequent :alternate) + (:alternate :consequent) + (t result))))) -(defun p2-test-char= (form) +(defun p2-test-char= (form success-label failure-label) (when (check-arg-count form 2) (let* ((arg1 (%cadr form)) (arg2 (%caddr form))) @@ -2595,9 +2624,9 @@ ((compile-operand arg1 :char) (compile-operand arg2 :char) (maybe-emit-clear-values arg1 arg2))) - 'if_icmpne))) + (emit-test-jump 'if_icmpne success-label failure-label)))) -(defun p2-test-eq (form) +(defun p2-test-eq (form success-label failure-label) (when (check-arg-count form 2) (let ((arg1 (%cadr form)) (arg2 (%caddr form))) @@ -2605,28 +2634,58 @@ ((compile-operand arg1 nil) (compile-operand arg2 nil) (maybe-emit-clear-values arg1 arg2))) - 'if_acmpne))) + (emit-test-jump 'if_acmpne success-label failure-label)))) + +(defun p2-test-or (form success-label failure-label) + (let ((args (cdr form))) + (case (length args) + (0 + :alternate) + (1 + (compile-test-form (%car args) success-label failure-label)) + (t + (loop + with local-success-label = (or success-label (gensym)) + for arg in args + for result = (compile-test-form arg local-success-label nil) + when (eq :consequent result) + do (progn + (emit 'goto local-success-label) + (loop-finish)) + finally (progn + (when failure-label + (emit 'goto failure-label)) + (unless (eq success-label local-success-label) + (label local-success-label)) + (return t))))))) -(defun p2-test-and (form) +(defun p2-test-and (form success-label failure-label) (let ((args (cdr form))) (case (length args) (0 :consequent) (1 - (compile-test-form (%car args))) - (2 - (compile-form form 'stack :boolean) - 'ifeq) + (compile-test-form (%car args) success-label failure-label)) (t - (compile-forms-and-maybe-emit-clear-values form 'stack nil) - (emit-push-nil) - 'if_acmpeq)))) - -(defun p2-test-neq (form) - (p2-test-eq form) - 'if_acmpeq) + (loop + with local-fail-label = (or failure-label (gensym)) + for arg in args + for result = (compile-test-form arg nil local-fail-label) + when (eq :alternate result) + do (progn + (emit 'goto local-fail-label) + (loop-finish)) + finally (progn + (when success-label + (emit 'goto success-label)) + (unless (eq failure-label local-fail-label) + (label local-fail-label)) + (return t))))))) -(defun p2-test-eql (form) +(defun p2-test-neq (form success-label failure-label) + (p2-test-eq form failure-label success-label)) + +(defun p2-test-eql (form success-label failure-label) (when (check-arg-count form 2) (let* ((arg1 (%cadr form)) (arg2 (%caddr form)) @@ -2637,20 +2696,20 @@ ((compile-operand arg1 :int) (compile-operand arg2 :int) (maybe-emit-clear-values arg1 arg2))) - 'if_icmpne) + (emit-test-jump 'if_icmpne success-label failure-label)) ((and (eq type1 'CHARACTER) (eq type2 'CHARACTER)) (with-operand-accumulation ((compile-operand arg1 :char) (compile-operand arg2 :char) (maybe-emit-clear-values arg1 arg2))) - 'if_icmpne) + (emit-test-jump 'if_icmpne success-label failure-label)) ((eq type2 'CHARACTER) (with-operand-accumulation ((compile-operand arg1 nil) (compile-operand arg2 :char) (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean) - 'ifeq) + (emit-test-jump 'ifeq success-label failure-label)) ((eq type1 'CHARACTER) (with-operand-accumulation ((compile-operand arg1 :char) @@ -2658,14 +2717,14 @@ (maybe-emit-clear-values arg1 arg2))) (emit 'swap) (emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean) - 'ifeq) + (emit-test-jump 'ifeq success-label failure-label)) ((fixnum-type-p type2) (with-operand-accumulation ((compile-operand arg1 nil) (compile-operand arg2 :int) (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean) - 'ifeq) + (emit-test-jump 'ifeq success-label failure-label)) ((fixnum-type-p type1) (with-operand-accumulation ((compile-operand arg1 :int) @@ -2673,7 +2732,7 @@ (maybe-emit-clear-values arg1 arg2))) (emit 'swap) (emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean) - 'ifeq) + (emit-test-jump 'ifeq success-label failure-label)) (t (with-operand-accumulation ((compile-operand arg1 nil) @@ -2681,9 +2740,9 @@ (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "eql" (lisp-object-arg-types 1) :boolean) - 'ifeq))))) + (emit-test-jump 'ifeq success-label failure-label)))))) -(defun p2-test-equality (form) +(defun p2-test-equality (form success-label failure-label) (when (check-arg-count form 2) (let* ((op (%car form)) (translated-op (ecase op @@ -2707,9 +2766,9 @@ (emit-invokevirtual +lisp-object+ translated-op (lisp-object-arg-types 1) :boolean))) - 'ifeq))) + (emit-test-jump 'ifeq success-label failure-label)))) -(defun p2-test-simple-typep (form) +(defun p2-test-simple-typep (form success-label failure-label) (when (check-arg-count form 2) (let ((arg1 (%cadr form)) (arg2 (%caddr form))) @@ -2720,9 +2779,9 @@ (emit-invokevirtual +lisp-object+ "typep" (lisp-object-arg-types 1) +lisp-object+) (emit-push-nil) - 'if_acmpeq))) + (emit-test-jump 'if_acmpeq success-label failure-label)))) -(defun p2-test-memq (form) +(defun p2-test-memq (form success-label failure-label) (when (check-arg-count form 2) (let ((arg1 (%cadr form)) (arg2 (%caddr form))) @@ -2732,9 +2791,9 @@ (maybe-emit-clear-values arg1 arg2))) (emit-invokestatic +lisp+ "memq" (lisp-object-arg-types 2) :boolean) - 'ifeq))) + (emit-test-jump 'ifeq success-label failure-label)))) -(defun p2-test-memql (form) +(defun p2-test-memql (form success-label failure-label) (when (check-arg-count form 2) (let ((arg1 (%cadr form)) (arg2 (%caddr form))) @@ -2744,9 +2803,9 @@ (maybe-emit-clear-values arg1 arg2))) (emit-invokestatic +lisp+ "memql" (lisp-object-arg-types 2) :boolean) - 'ifeq))) + (emit-test-jump 'ifeq success-label failure-label)))) -(defun p2-test-/= (form) +(defun p2-test-/= (form success-label failure-label) (when (= (length form) 3) (let* ((arg1 (%cadr form)) (arg2 (%caddr form)) @@ -2760,14 +2819,14 @@ ((compile-operand arg1 :int) (compile-operand arg2 :int) (maybe-emit-clear-values arg1 arg2))) - 'if_icmpeq) + (emit-test-jump 'if_icmpeq success-label failure-label)) ((fixnum-type-p type2) (with-operand-accumulation ((compile-operand arg1 nil) (compile-operand arg2 :int) (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean) - 'ifeq) + (emit-test-jump 'ifeq success-label failure-label)) ((fixnum-type-p type1) ;; FIXME Compile the args in reverse order and avoid the swap if ;; either arg is a fixnum or a lexical variable. @@ -2777,7 +2836,7 @@ (maybe-emit-clear-values arg1 arg2))) (emit 'swap) (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean) - 'ifeq) + (emit-test-jump 'ifeq success-label failure-label)) (t (with-operand-accumulation ((compile-operand arg1 nil) @@ -2785,9 +2844,9 @@ (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "isNotEqualTo" (lisp-object-arg-types 1) :boolean) - 'ifeq))))) + (emit-test-jump 'ifeq success-label failure-label)))))) -(defun p2-test-numeric-comparison (form) +(defun p2-test-numeric-comparison (form success-label failure-label) (when (check-min-args form 1) (when (= (length form) 3) (let* ((op (%car form)) @@ -2803,24 +2862,26 @@ ((compile-operand arg1 :int) (compile-operand arg2 :int) (maybe-emit-clear-values arg1 arg2))) - (ecase op - (< 'if_icmpge) - (<= 'if_icmpgt) - (> 'if_icmple) - (>= 'if_icmplt) - (= 'if_icmpne))) + (emit-test-jump (ecase op + (< 'if_icmpge) + (<= 'if_icmpgt) + (> 'if_icmple) + (>= 'if_icmplt) + (= 'if_icmpne)) + success-label failure-label)) ((and (java-long-type-p type1) (java-long-type-p type2)) (with-operand-accumulation ((compile-operand arg1 :long) (compile-operand arg2 :long) (maybe-emit-clear-values arg1 arg2))) (emit 'lcmp) - (ecase op - (< 'ifge) - (<= 'ifgt) - (> 'ifle) - (>= 'iflt) - (= 'ifne))) + (emit-test-jump (ecase op + (< 'ifge) + (<= 'ifgt) + (> 'ifle) + (>= 'iflt) + (= 'ifne)) + success-label failure-label)) ((fixnum-type-p type2) (with-operand-accumulation ((compile-operand arg1 nil) @@ -2834,7 +2895,7 @@ (>= "isGreaterThanOrEqualTo") (= "isEqualTo")) '(:int) :boolean) - 'ifeq) + (emit-test-jump 'ifeq success-label failure-label)) ((fixnum-type-p type1) ;; FIXME We can compile the args in reverse order and avoid ;; the swap if either arg is a fixnum or a lexical variable. @@ -2851,7 +2912,7 @@ (>= "isLessThanOrEqualTo") (= "isEqualTo")) '(:int) :boolean) - 'ifeq) + (emit-test-jump 'ifeq success-label failure-label)) (t (with-operand-accumulation ((compile-operand arg1 nil) @@ -2865,139 +2926,28 @@ (>= "isGreaterThanOrEqualTo") (= "isEqualTo")) (lisp-object-arg-types 1) :boolean) - 'ifeq)))))) + (emit-test-jump 'ifeq success-label failure-label))))))) -(defknown p2-if-or (t t t) t) -(defun p2-if-or (form target representation) - (let* ((test (second form)) - (consequent (third form)) - (alternate (fourth form)) - (LABEL1 (gensym)) - (LABEL2 (gensym))) - (aver (and (consp test) (eq (car test) 'OR))) - (let* ((args (cdr test))) - (case (length args) - (0 - (compile-form alternate target representation)) - (1 - (p2-if (list 'IF (%car args) consequent alternate) target representation)) - (t - (dolist (arg args) - (cond ((and (consp arg) (eq (first arg) 'EQ)) - ;; ERROR CHECKING HERE! - (let ((arg1 (second arg)) - (arg2 (third arg))) - (with-operand-accumulation - ((compile-operand arg1 nil) - (compile-operand arg2 nil) - (maybe-emit-clear-values arg1 arg2))) - (emit 'if_acmpeq LABEL1))) - ((eq (derive-compiler-type arg) 'BOOLEAN) - (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) - (emit 'ifne LABEL1)) - (t - (compile-forms-and-maybe-emit-clear-values arg 'stack nil) - (emit-push-nil) - (emit 'if_acmpne LABEL1)))) - (compile-form alternate target representation) - (emit 'goto LABEL2) - (label LABEL1) - (compile-form consequent target representation) - (label LABEL2)))))) - -(defknown p2-if-and (t t t) t) -(defun p2-if-and (form target representation) +(defknown p2-if (t t t) t) +(defun p2-if (form target representation) (let* ((test (second form)) (consequent (third form)) (alternate (fourth form)) (LABEL1 (gensym)) (LABEL2 (gensym))) - (aver (and (consp test) (eq (car test) 'AND))) - (let* ((args (cdr test))) - (case (length args) - (0 + (let ((result (compile-test-form test nil LABEL1))) + (case result + (:consequent (compile-form consequent target representation)) - (1 - (p2-if (list 'IF (%car args) consequent alternate) target representation)) + (:alternate + (compile-form alternate target representation)) (t - (dolist (arg args) - (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) - (emit 'ifeq LABEL1)) (compile-form consequent target representation) (emit 'goto LABEL2) (label LABEL1) (compile-form alternate target representation) (label LABEL2)))))) -(defknown p2-if-not-and (t t t) t) -(defun p2-if-not-and (form target representation) - (let* ((inverted-test (second (second form))) - (consequent (third form)) - (alternate (fourth form)) - (LABEL1 (gensym)) - (LABEL2 (gensym))) - (let* ((args (cdr inverted-test))) - (case (length args) - (0 - (compile-form alternate target representation)) - (1 - (p2-if (list 'IF (%car args) alternate consequent) target representation)) - (t - (dolist (arg args) - (let ((type (derive-compiler-type arg))) - (cond ((eq type 'BOOLEAN) - (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) - (emit 'ifeq LABEL1)) - (t - (compile-forms-and-maybe-emit-clear-values arg 'stack nil) - (emit-push-nil) - (emit 'if_acmpeq LABEL1))))) - (compile-form alternate target representation) - (emit 'goto LABEL2) - (label LABEL1) - (compile-form consequent target representation) - (label LABEL2)))))) - -(defknown p2-if (t t t) t) -(defun p2-if (form target representation) - (let* ((test (second form)) - (consequent (third form)) - (alternate (fourth form)) - (LABEL1 (gensym)) - (LABEL2 (gensym))) - (cond ((eq test t) - (compile-form consequent target representation)) - ((null test) - (compile-form alternate target representation)) - ((numberp test) - (compile-form consequent target representation)) - ((equal (derive-compiler-type test) +true-type+) - (compile-forms-and-maybe-emit-clear-values test nil nil) - (compile-form consequent target representation)) - ((and (consp test) (eq (car test) 'OR)) - (p2-if-or form target representation)) - ((and (consp test) (eq (car test) 'AND)) - (p2-if-and form target representation)) - ((and (consp test) - (memq (first test) '(NOT NULL)) - (consp (second test)) - (eq (first (second test)) 'AND)) - (p2-if-not-and form target representation)) - (t - (let ((result (compile-test-form test))) - (case result - (:consequent - (compile-form consequent target representation)) - (:alternate - (compile-form alternate target representation)) - (t - (emit result LABEL1) - (compile-form consequent target representation) - (emit 'goto LABEL2) - (label LABEL1) - (compile-form alternate target representation) - (label LABEL2)))))))) - (defun compile-multiple-value-list (form target representation) (emit-clear-values) (compile-form (second form) 'stack nil) From ehuelsmann at common-lisp.net Thu Mar 10 20:59:02 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 10 Mar 2011 15:59:02 -0500 Subject: [armedbear-cvs] r13242 - in public_html: . releases/0.25.0 Message-ID: Author: ehuelsmann Date: Thu Mar 10 15:58:58 2011 New Revision: 13242 Log: Publish our 0.25 release. Added: public_html/releases/0.25.0/ public_html/releases/0.25.0/abcl-bin-0.25.0.tar.gz (contents, props changed) public_html/releases/0.25.0/abcl-bin-0.25.0.tar.gz.asc public_html/releases/0.25.0/abcl-bin-0.25.0.zip (contents, props changed) public_html/releases/0.25.0/abcl-bin-0.25.0.zip.asc public_html/releases/0.25.0/abcl-src-0.25.0.tar.gz (contents, props changed) public_html/releases/0.25.0/abcl-src-0.25.0.tar.gz.asc public_html/releases/0.25.0/abcl-src-0.25.0.zip (contents, props changed) public_html/releases/0.25.0/abcl-src-0.25.0.zip.asc Modified: public_html/index.shtml public_html/left-menu Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Thu Mar 10 15:58:58 2011 @@ -61,24 +61,24 @@ Binary - abcl-bin-0.24.0.tar.gz - (pgp) + abcl-bin-0.25.0.tar.gz + (pgp) - abcl-bin-0.24.0.zip - (pgp) + abcl-bin-0.25.0.zip + (pgp) Source - abcl-src-0.24.0.tar.gz - (pgp) + abcl-src-0.25.0.tar.gz + (pgp) - abcl-src-0.24.0.zip - (pgp) + abcl-src-0.25.0.zip + (pgp) Modified: public_html/left-menu ============================================================================== --- public_html/left-menu (original) +++ public_html/left-menu Thu Mar 10 15:58:58 2011 @@ -1,7 +1,7 @@
Project page
Testimonials
-Release notes
+Release notes
Paid support
Added: public_html/releases/0.25.0/abcl-bin-0.25.0.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/0.25.0/abcl-bin-0.25.0.tar.gz.asc ============================================================================== --- (empty file) +++ public_html/releases/0.25.0/abcl-bin-0.25.0.tar.gz.asc Thu Mar 10 15:58:58 2011 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAk15MrAACgkQi5O0Epaz9Tk60wCcDVdutiQpHX1eQ3g8/g4nWAss +hlEAn2iRTFVLWBwgdkwLwmlug4uy3SY+ +=UX3O +-----END PGP SIGNATURE----- Added: public_html/releases/0.25.0/abcl-bin-0.25.0.zip ============================================================================== Binary file. No diff available. Added: public_html/releases/0.25.0/abcl-bin-0.25.0.zip.asc ============================================================================== --- (empty file) +++ public_html/releases/0.25.0/abcl-bin-0.25.0.zip.asc Thu Mar 10 15:58:58 2011 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAk15MrsACgkQi5O0Epaz9Tm97gCfVkn/U9prjnhGPfIi//LllJDL +N50AnjYfzFcnbrpG3ffXyIjz8EWgALjP +=dxcj +-----END PGP SIGNATURE----- Added: public_html/releases/0.25.0/abcl-src-0.25.0.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/0.25.0/abcl-src-0.25.0.tar.gz.asc ============================================================================== --- (empty file) +++ public_html/releases/0.25.0/abcl-src-0.25.0.tar.gz.asc Thu Mar 10 15:58:58 2011 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAk15MscACgkQi5O0Epaz9TlJ8QCeNiV8Vjmqmjenpda8xIOzwYAk +f+MAn0EApiPLMPKyNMq41hXLJwxUHTUw +=sJIL +-----END PGP SIGNATURE----- Added: public_html/releases/0.25.0/abcl-src-0.25.0.zip ============================================================================== Binary file. No diff available. Added: public_html/releases/0.25.0/abcl-src-0.25.0.zip.asc ============================================================================== --- (empty file) +++ public_html/releases/0.25.0/abcl-src-0.25.0.zip.asc Thu Mar 10 15:58:58 2011 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAk15Ms4ACgkQi5O0Epaz9TmR/gCeMIoqQDohMHAguy9nUCm+7nML +2ocAn15yXQ+dnRLn0PnSHqo7SlH/4UI/ +=T+Dv +-----END PGP SIGNATURE----- From vvoutilainen at common-lisp.net Sat Mar 12 19:18:07 2011 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sat, 12 Mar 2011 14:18:07 -0500 Subject: [armedbear-cvs] r13243 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sat Mar 12 14:18:05 2011 New Revision: 13243 Log: This patch fixes 1) recursion with wild-inferiors for paths like "/usr/share/**/ui/*.xml" The previous code didn't recurse into directories not named "ui" at all in that case. 2) symlinks that point to the current directory 3) the listing returned by list-directories-with-wildcards can return paths for which file-namestring is nil, protect the filtering from barfing on those. 4) tabs in the file. Sure, this should be done separately but we have reviewed the changes without the tab change so we'll do it with the same patch. Modified: trunk/abcl/src/org/armedbear/lisp/directory.lisp Modified: trunk/abcl/src/org/armedbear/lisp/directory.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/directory.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/directory.lisp Sat Mar 12 14:18:05 2011 @@ -48,48 +48,53 @@ wild-inferiors-found resolve-symlinks) (let* ((directory (pathname-directory pathname)) - (first-wild-inferior (and (not wild-inferiors-found) - (position-if #'wild-inferiors-p directory))) - (first-wild (position-if #'wild-p directory)) - (wild (when (or first-wild-inferior first-wild) - (nthcdr (or first-wild-inferior first-wild) directory))) - (non-wild (if (or first-wild-inferior first-wild) - (nbutlast directory - (- (length directory) - (or first-wild-inferior first-wild))) - directory)) - (newpath (make-pathname :directory non-wild - :name nil :type nil :defaults pathname)) - (entries (list-directory newpath resolve-symlinks))) + (first-wild-inferior (and (not wild-inferiors-found) + (position-if #'wild-inferiors-p directory))) + (first-wild (position-if #'wild-p directory)) + (wild (when (or first-wild-inferior first-wild) + (nthcdr (or first-wild-inferior first-wild) directory))) + (non-wild (if (or first-wild-inferior first-wild) + (nbutlast directory + (- (length directory) + (or first-wild-inferior first-wild))) + directory)) + (newpath (make-pathname :directory non-wild + :name nil :type nil :defaults pathname)) + (entries (list-directory newpath resolve-symlinks))) (if (not (or wild wild-inferiors-found)) - entries - (let ((inferior-entries (when (or wild-inferiors-found first-wild-inferior) entries))) - (nconc - (mapcan (lambda (entry) - (when (pathname-match-p (pathname entry) pathname) - (list entry))) - inferior-entries) - (mapcan (lambda (entry) - (let* ((pathname (pathname entry)) - (directory (pathname-directory pathname)) - (rest-wild (cdr wild))) - (unless (pathname-name pathname) - (when (pathname-match-p (first (last directory)) - (cond ((eql (car wild) :wild) - "*") - ((eql (car wild) :wild-inferiors) - "*") - (wild - (car wild)) - (t ""))) - (when rest-wild - (setf directory (nconc directory rest-wild))) - (list-directories-with-wildcards - (make-pathname :directory directory - :defaults newpath) - (or first-wild-inferior wild-inferiors-found) - resolve-symlinks))))) - entries)))))) + entries + (let ((inferior-entries (when (or wild-inferiors-found first-wild-inferior) entries))) + (nconc + (mapcan (lambda (entry) + (when (pathname-match-p (pathname entry) pathname) + (list entry))) + inferior-entries) + (mapcan (lambda (entry) + (let* ((pathname (pathname entry)) + (directory (pathname-directory pathname)) + (rest-wild (cdr wild))) + (unless (pathname-name pathname) + (when (pathname-match-p (first (last directory)) + (cond ((eql (car wild) :wild) + "*") + ((eql (car wild) :wild-inferiors) + "*") + (wild + (car wild)) + (t ""))) + (when (and + (not (or first-wild-inferior + wild-inferiors-found)) + rest-wild) + (setf directory (nconc directory rest-wild))) + (let ((recurse (make-pathname :directory directory + :defaults newpath))) + (when (not (equal recurse newpath)) + (list-directories-with-wildcards + recurse + (or first-wild-inferior wild-inferiors-found) + resolve-symlinks))))))) + entries)))))) (defun directory (pathspec &key (resolve-symlinks t)) @@ -97,7 +102,7 @@ (when (logical-pathname-p pathname) (setq pathname (translate-logical-pathname pathname))) (if (or (position #\* (namestring pathname)) - (wild-pathname-p pathname)) + (wild-pathname-p pathname)) (if (pathname-jar-p pathname) (match-wild-jar-pathname pathname) (let ((namestring (directory-namestring pathname))) @@ -113,7 +118,7 @@ (cond ((file-directory-p entry) (when (pathname-match-p (file-namestring (pathname-as-file entry)) (file-namestring pathname)) (push entry matching-entries))) - ((pathname-match-p (file-namestring entry) (file-namestring pathname)) + ((pathname-match-p (or (file-namestring entry) "") (file-namestring pathname)) (push entry matching-entries)))) matching-entries)))) ;; Not wild. From vvoutilainen at common-lisp.net Sat Mar 12 19:57:49 2011 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sat, 12 Mar 2011 14:57:49 -0500 Subject: [armedbear-cvs] r13244 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sat Mar 12 14:57:48 2011 New Revision: 13244 Log: Fix directory listings for files that have funny names like File::Spec::VMS.3perl.gz. The wildcard filtering is broken atm, working on that. Modified: trunk/abcl/src/org/armedbear/lisp/directory.lisp Modified: trunk/abcl/src/org/armedbear/lisp/directory.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/directory.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/directory.lisp Sat Mar 12 14:57:48 2011 @@ -116,9 +116,9 @@ (matching-entries ())) (dolist (entry entries) (cond ((file-directory-p entry) - (when (pathname-match-p (file-namestring (pathname-as-file entry)) (file-namestring pathname)) + (when (pathname-match-p (make-pathname :name (file-namestring (pathname-as-file entry))) (make-pathname :name (file-namestring pathname))) (push entry matching-entries))) - ((pathname-match-p (or (file-namestring entry) "") (file-namestring pathname)) + ((pathname-match-p (make-pathname :name (or (file-namestring entry) "")) (make-pathname :name (file-namestring pathname))) (push entry matching-entries)))) matching-entries)))) ;; Not wild. From ehuelsmann at common-lisp.net Sat Mar 12 22:05:20 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 12 Mar 2011 17:05:20 -0500 Subject: [armedbear-cvs] r13245 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Mar 12 17:05:19 2011 New Revision: 13245 Log: Fix docstring annotation, replacing '=' by '-' in the symbol name. Modified: trunk/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java Modified: trunk/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java Sat Mar 12 17:05:19 2011 @@ -76,7 +76,7 @@ return unreadableString(sb.toString()); } - @DocString(name="make-forward-referenced=class") + @DocString(name="make-forward-referenced-class") private static final Primitive MAKE_FORWARD_REFERENCED_CLASS = new Primitive("make-forward-referenced-class", PACKAGE_SYS, true) { From ehuelsmann at common-lisp.net Sat Mar 12 22:41:51 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 12 Mar 2011 17:41:51 -0500 Subject: [armedbear-cvs] r13246 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Mar 12 17:41:50 2011 New Revision: 13246 Log: Fix #139 by adding weak object reference support. Added: trunk/abcl/src/org/armedbear/lisp/WeakReference.java Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java trunk/abcl/src/org/armedbear/lisp/Symbol.java Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java Sat Mar 12 17:41:50 2011 @@ -141,6 +141,7 @@ public static final BuiltInClass STACK_FRAME = addClass(Symbol.STACK_FRAME); public static final BuiltInClass LISP_STACK_FRAME = addClass(Symbol.LISP_STACK_FRAME); public static final BuiltInClass JAVA_STACK_FRAME = addClass(Symbol.JAVA_STACK_FRAME); + public static final BuiltInClass WEAK_REFERENCE = addClass(Symbol.WEAK_REFERENCE); public static final StructureClass STRUCTURE_OBJECT = Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Sat Mar 12 17:41:50 2011 @@ -2947,6 +2947,8 @@ PACKAGE_EXT.addExternalSymbol("JAR-PATHNAME"); public static final Symbol URL_PATHNAME = PACKAGE_EXT.addExternalSymbol("URL-PATHNAME"); + public static final Symbol WEAK_REFERENCE = + PACKAGE_EXT.addExternalSymbol("WEAK-REFERENCE"); // MOP. public static final Symbol CLASS_LAYOUT = Added: trunk/abcl/src/org/armedbear/lisp/WeakReference.java ============================================================================== --- (empty file) +++ trunk/abcl/src/org/armedbear/lisp/WeakReference.java Sat Mar 12 17:41:50 2011 @@ -0,0 +1,112 @@ +/* + * WeakReference.java + * + * Copyright (C) 2011 Erik Huelsmann + * $Id: JavaStackFrame.java 12288 2009-11-29 22:00:12Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ +package org.armedbear.lisp; + +import static org.armedbear.lisp.Lisp.*; + +public class WeakReference extends LispObject { + + java.lang.ref.WeakReference ref; + + public WeakReference(LispObject ref) { + this.ref = new java.lang.ref.WeakReference(ref); + } + + @Override + public LispObject typeOf() { + return Symbol.WEAK_REFERENCE; + } + + @Override + public LispObject classOf() { + return BuiltInClass.WEAK_REFERENCE; + } + + @Override + public String writeToString() { + return unreadableString("WEAK-REFERENCE " + + toString()); + } + + @Override + public LispObject typep(LispObject typeSpecifier) { + if (typeSpecifier == Symbol.WEAK_REFERENCE) { + return T; + } + if (typeSpecifier == BuiltInClass.WEAK_REFERENCE) { + return T; + } + return super.typep(typeSpecifier); + } + + private static final Primitive MAKE_WEAK_REFERENCE = + new pf_make_weak_reference(); + @DocString(name="make-weak-reference", args="obj", + doc="Creates a weak reference to 'obj'.") + private static final class pf_make_weak_reference extends Primitive + { + pf_make_weak_reference() + { + super("make-weak-reference", PACKAGE_EXT, true); + } + + @Override + public LispObject execute(LispObject obj) { + return new WeakReference(obj); + } + }; + + private static final Primitive WEAK_REFERENCE_VALUE = + new pf_weak_reference_value(); + @DocString(name="weak-reference-value", args="obj", + doc="Returns two values, the first being the value of the weak ref," + + "the second T if the reference is valid, or NIL if it has" + + "been cleared.") + private static final class pf_weak_reference_value extends Primitive + { + pf_weak_reference_value() + { + super("weak-reference-value", PACKAGE_EXT, true); + } + + @Override + public LispObject execute(LispObject obj) { + if (! (obj instanceof WeakReference)) + return Lisp.type_error(obj, Symbol.WEAK_REFERENCE); + + LispObject value = ((WeakReference)obj).ref.get(); + return LispThread.currentThread().setValues(value == null ? NIL : value, + value == null ? NIL : T); + } + }; +} From ehuelsmann at common-lisp.net Sat Mar 12 22:46:01 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 12 Mar 2011 17:46:01 -0500 Subject: [armedbear-cvs] r13247 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Mar 12 17:46:00 2011 New Revision: 13247 Log: Re #139, add autoloading of WeakReference related symbols. Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Sat Mar 12 17:46:00 2011 @@ -517,6 +517,8 @@ autoload(PACKAGE_EXT, "string-input-stream-current", "StringInputStream", true); autoload(PACKAGE_EXT, "string-find", "StringFunctions"); autoload(PACKAGE_EXT, "string-position", "StringFunctions"); + autoload(PACKAGE_EXT, "make-weak-reference", "WeakReference", true); + autoload(PACKAGE_EXT, "weak-reference-value", "WeakReference", true); autoload(PACKAGE_JAVA, "%jnew-proxy", "JProxy"); autoload(PACKAGE_JAVA, "%find-java-class", "JavaObject"); autoload(PACKAGE_JAVA, "%register-java-class", "JavaObject"); From ehuelsmann at common-lisp.net Sat Mar 12 23:08:23 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 12 Mar 2011 18:08:23 -0500 Subject: [armedbear-cvs] r13248 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Mar 12 18:08:21 2011 New Revision: 13248 Log: Close #138 by implementing finalizers on LispObject derived objects. Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/LispObject.java trunk/abcl/src/org/armedbear/lisp/Primitives.java Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Sat Mar 12 18:08:21 2011 @@ -519,6 +519,8 @@ autoload(PACKAGE_EXT, "string-position", "StringFunctions"); autoload(PACKAGE_EXT, "make-weak-reference", "WeakReference", true); autoload(PACKAGE_EXT, "weak-reference-value", "WeakReference", true); + autoload(PACKAGE_EXT, "finalize", "Primitives", true); + autoload(PACKAGE_EXT, "cancel-finalization", "Primitives", true); autoload(PACKAGE_JAVA, "%jnew-proxy", "JProxy"); autoload(PACKAGE_JAVA, "%find-java-class", "JavaObject"); autoload(PACKAGE_JAVA, "%register-java-class", "JavaObject"); Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Sat Mar 12 18:08:21 2011 @@ -1284,4 +1284,25 @@ public void incrementHotCount() { } + + private Cons finalizers = null; + + synchronized public void addFinalizer(LispObject fun) { + finalizers = new Cons(fun, finalizers); + } + + synchronized public void cancelFinalizers() { + finalizers = null; + } + + @Override + @SuppressWarnings("FinalizeDeclaration") + protected void finalize() + throws Throwable { + while (finalizers != null) { + finalizers.car.execute(); + finalizers = (Cons)finalizers.cdr; + } + super.finalize(); + } } Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Sat Mar 12 18:08:21 2011 @@ -2,6 +2,7 @@ * Primitives.java * * Copyright (C) 2002-2007 Peter Graves + * Copyright (C) 2011 Erik Huelsmann * $Id$ * * This program is free software; you can redistribute it and/or @@ -5818,4 +5819,34 @@ } }; + // ### finalize + private static final Primitive FINALIZE + = new pf_finalize(); + private static final class pf_finalize extends Primitive { + pf_finalize() { + super("finalize", PACKAGE_EXT, true, "object function"); + } + + @Override + public LispObject execute(LispObject obj, LispObject fun) { + obj.addFinalizer(fun); + return obj; + } + }; + + // ### cancel-finalization + private static final Primitive CANCEL_FINALIZATION + = new pf_cancel_finalization(); + private static final class pf_cancel_finalization extends Primitive { + pf_cancel_finalization() { + super("cancel-finalization", PACKAGE_EXT, true, "object"); + } + + @Override + public LispObject execute(LispObject obj) { + obj.cancelFinalizers(); + return obj; + } + }; + } From ehuelsmann at common-lisp.net Sun Mar 13 10:17:13 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 13 Mar 2011 06:17:13 -0400 Subject: [armedbear-cvs] r13249 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Mar 13 06:17:10 2011 New Revision: 13249 Log: Revert r13248, "Close #138 by implementing finalizers on LispObject." since it breaks trunk building. Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/LispObject.java trunk/abcl/src/org/armedbear/lisp/Primitives.java Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Sun Mar 13 06:17:10 2011 @@ -519,8 +519,6 @@ autoload(PACKAGE_EXT, "string-position", "StringFunctions"); autoload(PACKAGE_EXT, "make-weak-reference", "WeakReference", true); autoload(PACKAGE_EXT, "weak-reference-value", "WeakReference", true); - autoload(PACKAGE_EXT, "finalize", "Primitives", true); - autoload(PACKAGE_EXT, "cancel-finalization", "Primitives", true); autoload(PACKAGE_JAVA, "%jnew-proxy", "JProxy"); autoload(PACKAGE_JAVA, "%find-java-class", "JavaObject"); autoload(PACKAGE_JAVA, "%register-java-class", "JavaObject"); Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Sun Mar 13 06:17:10 2011 @@ -1284,25 +1284,4 @@ public void incrementHotCount() { } - - private Cons finalizers = null; - - synchronized public void addFinalizer(LispObject fun) { - finalizers = new Cons(fun, finalizers); - } - - synchronized public void cancelFinalizers() { - finalizers = null; - } - - @Override - @SuppressWarnings("FinalizeDeclaration") - protected void finalize() - throws Throwable { - while (finalizers != null) { - finalizers.car.execute(); - finalizers = (Cons)finalizers.cdr; - } - super.finalize(); - } } Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Sun Mar 13 06:17:10 2011 @@ -2,7 +2,6 @@ * Primitives.java * * Copyright (C) 2002-2007 Peter Graves - * Copyright (C) 2011 Erik Huelsmann * $Id$ * * This program is free software; you can redistribute it and/or @@ -5819,34 +5818,4 @@ } }; - // ### finalize - private static final Primitive FINALIZE - = new pf_finalize(); - private static final class pf_finalize extends Primitive { - pf_finalize() { - super("finalize", PACKAGE_EXT, true, "object function"); - } - - @Override - public LispObject execute(LispObject obj, LispObject fun) { - obj.addFinalizer(fun); - return obj; - } - }; - - // ### cancel-finalization - private static final Primitive CANCEL_FINALIZATION - = new pf_cancel_finalization(); - private static final class pf_cancel_finalization extends Primitive { - pf_cancel_finalization() { - super("cancel-finalization", PACKAGE_EXT, true, "object"); - } - - @Override - public LispObject execute(LispObject obj) { - obj.cancelFinalizers(); - return obj; - } - }; - } From ehuelsmann at common-lisp.net Sun Mar 13 19:55:54 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 13 Mar 2011 15:55:54 -0400 Subject: [armedbear-cvs] r13250 - in trunk/abcl/src/org/armedbear/lisp: . util Message-ID: Author: ehuelsmann Date: Sun Mar 13 15:55:52 2011 New Revision: 13250 Log: Close #138 by implementing a general post-finalization notification mechanism. Added: trunk/abcl/src/org/armedbear/lisp/util/Finalizer.java Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/Primitives.java Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Sun Mar 13 15:55:52 2011 @@ -519,6 +519,8 @@ autoload(PACKAGE_EXT, "string-position", "StringFunctions"); autoload(PACKAGE_EXT, "make-weak-reference", "WeakReference", true); autoload(PACKAGE_EXT, "weak-reference-value", "WeakReference", true); + autoload(PACKAGE_EXT, "finalize", "Primitives", true); + autoload(PACKAGE_EXT, "cancel-finalization", "Primitives", true); autoload(PACKAGE_JAVA, "%jnew-proxy", "JProxy"); autoload(PACKAGE_JAVA, "%find-java-class", "JavaObject"); autoload(PACKAGE_JAVA, "%register-java-class", "JavaObject"); Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Sun Mar 13 15:55:52 2011 @@ -2,6 +2,7 @@ * Primitives.java * * Copyright (C) 2002-2007 Peter Graves + * Copyright (C) 2011 Erik Huelsmann * $Id$ * * This program is free software; you can redistribute it and/or @@ -37,6 +38,7 @@ import java.math.BigInteger; import java.util.ArrayList; +import org.armedbear.lisp.util.Finalizer; public final class Primitives { // ### * @@ -5818,4 +5820,39 @@ } }; + // ### finalize + private static final Primitive FINALIZE + = new pf_finalize(); + private static final class pf_finalize extends Primitive { + pf_finalize() { + super("finalize", PACKAGE_EXT, true, "object function"); + } + + @Override + public LispObject execute(LispObject obj, final LispObject fun) { + Finalizer.addFinalizer(obj, new Runnable() { + @Override + public void run() { + fun.execute(); + } + }); + return obj; + } + }; + + // ### cancel-finalization + private static final Primitive CANCEL_FINALIZATION + = new pf_cancel_finalization(); + private static final class pf_cancel_finalization extends Primitive { + pf_cancel_finalization() { + super("cancel-finalization", PACKAGE_EXT, true, "object"); + } + + @Override + public LispObject execute(LispObject obj) { + Finalizer.clearFinalizers(obj); + return obj; + } + }; + } Added: trunk/abcl/src/org/armedbear/lisp/util/Finalizer.java ============================================================================== --- (empty file) +++ trunk/abcl/src/org/armedbear/lisp/util/Finalizer.java Sun Mar 13 15:55:52 2011 @@ -0,0 +1,172 @@ +/* + * Finalizer.java + * + * Copyright (C) 2010 Mark Evenson + * $Id: HttpHead.java 12656 2010-05-06 20:15:26Z mevenson $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ +package org.armedbear.lisp.util; + +import java.lang.ref.ReferenceQueue; +import java.util.Collections; +import java.util.HashMap; +import java.util.Iterator; +import java.util.LinkedList; +import java.util.Map; +import java.util.WeakHashMap; + +/** Framework to monitor arbitrary objects to see if they have been + * garbage collected, running one or more runnables when they have. + */ +public class Finalizer { + + /** Internal weak reference class which keeps a list of Runnables + * with finalizing actions to be executed. + */ + private static class FinalizingWeakReference + extends java.lang.ref.WeakReference { + + /** Queue of Runnables to be executed after the object is GC-ed. */ + private LinkedList finalizers = new LinkedList(); + + FinalizingWeakReference(Object o, ReferenceQueue q, Runnable finalizer) { + super(o, q); + finalizers.add(finalizer); + } + + /** Adds a finalizer. + * + * Finalizers will be run in reverse-registration order. + * + * @param finalizer The finalizer to be added. + */ + void addFinalizer(Runnable finalizer) { + finalizers.add(finalizer); + } + + /** Removes all registered finalizers. */ + void cancelFinalizers() { + finalizers.clear(); + } + + /** Runs all finalizers registered. */ + void run() { + Iterator iterator = finalizers.iterator(); + while (iterator.hasNext()) { + iterator.next().run(); + } + } + } + + /** Queue for FinalizingWeakReference objects which need + * to have their references run because the associated + * object has been garbage collected + */ + private static ReferenceQueue queue = null; + + /** A map from objects to their associated FinalizingWeakReferences + * which is used by the routine which cancels finalization. + */ + private static Map references = null; + + /** A map which maps the finalizing references onto themselves. This map + * makes sure that hard (as opposed to weak) references stay around to + * prevent garbage collection of the FinalizingWeakReferences before the + * referred objects are. + */ + private static Map anchor = null; + + /** Checks that the internal administration variables and thread have been + * correctly set up. This solution allows the GC monitoring thread to be + * started as late as its first use. + */ + synchronized private static void checkQueue() { + if (queue == null) { + queue = new ReferenceQueue(); + references = Collections.synchronizedMap(new WeakHashMap()); + anchor = Collections.synchronizedMap(new HashMap()); + + Thread handler = + new Thread(new Runnable() { + + public void run() { + while (true) { + try { + FinalizingWeakReference ref = + (FinalizingWeakReference) queue.remove(); + anchor.remove(ref); + ref.run(); + } catch (InterruptedException i) { + } + } + } + }, "ABCL finalizer"); + + handler.setPriority(Thread.MAX_PRIORITY); + handler.setDaemon(true); + handler.start(); + } + } + + /** Schedules a Runnable to be run after garbage collection of the object. + * + * Note that the Runnable can't contain references to the object to be + * collected: it will disable garbage collection of the object. + * + * @param o The object to monitor for garbage collection + * @param r The routine to be executed after GC-ing the object + */ + public static void addFinalizer(Object o, Runnable r) { + if (queue == null) { + checkQueue(); + } + + FinalizingWeakReference ref = references.get(o); + if (ref != null) { + ref.addFinalizer(r); + } else { + ref = new FinalizingWeakReference(o, queue, r); + references.put(o, ref); + anchor.put(ref, ref); + } + } + + /** Cancels any references scheduled to be run after garbage + * collection of the argument 'o'. + * + * @param o Object to cancel references for + */ + public static void clearFinalizers(Object o) { + FinalizingWeakReference ref = references.get(o); + + if (ref != null) { + ref.cancelFinalizers(); + anchor.remove(ref); + } + } +} From ehuelsmann at common-lisp.net Sun Mar 13 19:59:42 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 13 Mar 2011 15:59:42 -0400 Subject: [armedbear-cvs] r13251 - trunk/abcl/src/org/armedbear/lisp/util Message-ID: Author: ehuelsmann Date: Sun Mar 13 15:59:41 2011 New Revision: 13251 Log: Set properties and correct attribution. Modified: trunk/abcl/src/org/armedbear/lisp/util/Finalizer.java (contents, props changed) Modified: trunk/abcl/src/org/armedbear/lisp/util/Finalizer.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/util/Finalizer.java (original) +++ trunk/abcl/src/org/armedbear/lisp/util/Finalizer.java Sun Mar 13 15:59:41 2011 @@ -1,172 +1,172 @@ -/* - * Finalizer.java - * - * Copyright (C) 2010 Mark Evenson - * $Id: HttpHead.java 12656 2010-05-06 20:15:26Z mevenson $ - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - * - * As a special exception, the copyright holders of this library give you - * permission to link this library with independent modules to produce an - * executable, regardless of the license terms of these independent - * modules, and to copy and distribute the resulting executable under - * terms of your choice, provided that you also meet, for each linked - * independent module, the terms and conditions of the license of that - * module. An independent module is a module which is not derived from - * or based on this library. If you modify this library, you may extend - * this exception to your version of the library, but you are not - * obligated to do so. If you do not wish to do so, delete this - * exception statement from your version. - */ -package org.armedbear.lisp.util; - -import java.lang.ref.ReferenceQueue; -import java.util.Collections; -import java.util.HashMap; -import java.util.Iterator; -import java.util.LinkedList; -import java.util.Map; -import java.util.WeakHashMap; - -/** Framework to monitor arbitrary objects to see if they have been - * garbage collected, running one or more runnables when they have. - */ -public class Finalizer { - - /** Internal weak reference class which keeps a list of Runnables - * with finalizing actions to be executed. - */ - private static class FinalizingWeakReference - extends java.lang.ref.WeakReference { - - /** Queue of Runnables to be executed after the object is GC-ed. */ - private LinkedList finalizers = new LinkedList(); - - FinalizingWeakReference(Object o, ReferenceQueue q, Runnable finalizer) { - super(o, q); - finalizers.add(finalizer); - } - - /** Adds a finalizer. - * - * Finalizers will be run in reverse-registration order. - * - * @param finalizer The finalizer to be added. - */ - void addFinalizer(Runnable finalizer) { - finalizers.add(finalizer); - } - - /** Removes all registered finalizers. */ - void cancelFinalizers() { - finalizers.clear(); - } - - /** Runs all finalizers registered. */ - void run() { - Iterator iterator = finalizers.iterator(); - while (iterator.hasNext()) { - iterator.next().run(); - } - } - } - - /** Queue for FinalizingWeakReference objects which need - * to have their references run because the associated - * object has been garbage collected - */ - private static ReferenceQueue queue = null; - - /** A map from objects to their associated FinalizingWeakReferences - * which is used by the routine which cancels finalization. - */ - private static Map references = null; - - /** A map which maps the finalizing references onto themselves. This map - * makes sure that hard (as opposed to weak) references stay around to - * prevent garbage collection of the FinalizingWeakReferences before the - * referred objects are. - */ - private static Map anchor = null; - - /** Checks that the internal administration variables and thread have been - * correctly set up. This solution allows the GC monitoring thread to be - * started as late as its first use. - */ - synchronized private static void checkQueue() { - if (queue == null) { - queue = new ReferenceQueue(); - references = Collections.synchronizedMap(new WeakHashMap()); - anchor = Collections.synchronizedMap(new HashMap()); - - Thread handler = - new Thread(new Runnable() { - - public void run() { - while (true) { - try { - FinalizingWeakReference ref = - (FinalizingWeakReference) queue.remove(); - anchor.remove(ref); - ref.run(); - } catch (InterruptedException i) { - } - } - } - }, "ABCL finalizer"); - - handler.setPriority(Thread.MAX_PRIORITY); - handler.setDaemon(true); - handler.start(); - } - } - - /** Schedules a Runnable to be run after garbage collection of the object. - * - * Note that the Runnable can't contain references to the object to be - * collected: it will disable garbage collection of the object. - * - * @param o The object to monitor for garbage collection - * @param r The routine to be executed after GC-ing the object - */ - public static void addFinalizer(Object o, Runnable r) { - if (queue == null) { - checkQueue(); - } - - FinalizingWeakReference ref = references.get(o); - if (ref != null) { - ref.addFinalizer(r); - } else { - ref = new FinalizingWeakReference(o, queue, r); - references.put(o, ref); - anchor.put(ref, ref); - } - } - - /** Cancels any references scheduled to be run after garbage - * collection of the argument 'o'. - * - * @param o Object to cancel references for - */ - public static void clearFinalizers(Object o) { - FinalizingWeakReference ref = references.get(o); - - if (ref != null) { - ref.cancelFinalizers(); - anchor.remove(ref); - } - } -} +/* + * Finalizer.java + * + * Copyright (C) 2011 Erik Huelsmann + * $Id$ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ +package org.armedbear.lisp.util; + +import java.lang.ref.ReferenceQueue; +import java.util.Collections; +import java.util.HashMap; +import java.util.Iterator; +import java.util.LinkedList; +import java.util.Map; +import java.util.WeakHashMap; + +/** Framework to monitor arbitrary objects to see if they have been + * garbage collected, running one or more runnables when they have. + */ +public class Finalizer { + + /** Internal weak reference class which keeps a list of Runnables + * with finalizing actions to be executed. + */ + private static class FinalizingWeakReference + extends java.lang.ref.WeakReference { + + /** Queue of Runnables to be executed after the object is GC-ed. */ + private LinkedList finalizers = new LinkedList(); + + FinalizingWeakReference(Object o, ReferenceQueue q, Runnable finalizer) { + super(o, q); + finalizers.add(finalizer); + } + + /** Adds a finalizer. + * + * Finalizers will be run in reverse-registration order. + * + * @param finalizer The finalizer to be added. + */ + void addFinalizer(Runnable finalizer) { + finalizers.add(finalizer); + } + + /** Removes all registered finalizers. */ + void cancelFinalizers() { + finalizers.clear(); + } + + /** Runs all finalizers registered. */ + void run() { + Iterator iterator = finalizers.iterator(); + while (iterator.hasNext()) { + iterator.next().run(); + } + } + } + + /** Queue for FinalizingWeakReference objects which need + * to have their references run because the associated + * object has been garbage collected + */ + private static ReferenceQueue queue = null; + + /** A map from objects to their associated FinalizingWeakReferences + * which is used by the routine which cancels finalization. + */ + private static Map references = null; + + /** A map which maps the finalizing references onto themselves. This map + * makes sure that hard (as opposed to weak) references stay around to + * prevent garbage collection of the FinalizingWeakReferences before the + * referred objects are. + */ + private static Map anchor = null; + + /** Checks that the internal administration variables and thread have been + * correctly set up. This solution allows the GC monitoring thread to be + * started as late as its first use. + */ + synchronized private static void checkQueue() { + if (queue == null) { + queue = new ReferenceQueue(); + references = Collections.synchronizedMap(new WeakHashMap()); + anchor = Collections.synchronizedMap(new HashMap()); + + Thread handler = + new Thread(new Runnable() { + + public void run() { + while (true) { + try { + FinalizingWeakReference ref = + (FinalizingWeakReference) queue.remove(); + anchor.remove(ref); + ref.run(); + } catch (InterruptedException i) { + } + } + } + }, "ABCL finalizer"); + + handler.setPriority(Thread.MAX_PRIORITY); + handler.setDaemon(true); + handler.start(); + } + } + + /** Schedules a Runnable to be run after garbage collection of the object. + * + * Note that the Runnable can't contain references to the object to be + * collected: it will disable garbage collection of the object. + * + * @param o The object to monitor for garbage collection + * @param r The routine to be executed after GC-ing the object + */ + public static void addFinalizer(Object o, Runnable r) { + if (queue == null) { + checkQueue(); + } + + FinalizingWeakReference ref = references.get(o); + if (ref != null) { + ref.addFinalizer(r); + } else { + ref = new FinalizingWeakReference(o, queue, r); + references.put(o, ref); + anchor.put(ref, ref); + } + } + + /** Cancels any references scheduled to be run after garbage + * collection of the argument 'o'. + * + * @param o Object to cancel references for + */ + public static void clearFinalizers(Object o) { + FinalizingWeakReference ref = references.get(o); + + if (ref != null) { + ref.cancelFinalizers(); + anchor.remove(ref); + } + } +} From vvoutilainen at common-lisp.net Wed Mar 16 18:36:41 2011 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Wed, 16 Mar 2011 14:36:41 -0400 Subject: [armedbear-cvs] r13252 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Wed Mar 16 14:36:39 2011 New Revision: 13252 Log: Revert the fix attempt for files with names like File::Foo::Bar. It breaks normal directory listings. Modified: trunk/abcl/src/org/armedbear/lisp/directory.lisp Modified: trunk/abcl/src/org/armedbear/lisp/directory.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/directory.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/directory.lisp Wed Mar 16 14:36:39 2011 @@ -116,9 +116,9 @@ (matching-entries ())) (dolist (entry entries) (cond ((file-directory-p entry) - (when (pathname-match-p (make-pathname :name (file-namestring (pathname-as-file entry))) (make-pathname :name (file-namestring pathname))) + (when (pathname-match-p (file-namestring (pathname-as-file entry)) (file-namestring pathname)) (push entry matching-entries))) - ((pathname-match-p (make-pathname :name (or (file-namestring entry) "")) (make-pathname :name (file-namestring pathname))) + ((pathname-match-p (or (file-namestring entry) "") (file-namestring pathname)) (push entry matching-entries)))) matching-entries)))) ;; Not wild. From mevenson at common-lisp.net Sun Mar 20 15:18:26 2011 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 20 Mar 2011 11:18:26 -0400 Subject: [armedbear-cvs] r13253 - in trunk/abcl: doc/asdf src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun Mar 20 11:18:25 2011 New Revision: 13253 Log: Upgrade to asdf-2.013. Modified: trunk/abcl/doc/asdf/asdf.texinfo trunk/abcl/src/org/armedbear/lisp/asdf.lisp Modified: trunk/abcl/doc/asdf/asdf.texinfo ============================================================================== --- trunk/abcl/doc/asdf/asdf.texinfo (original) +++ trunk/abcl/doc/asdf/asdf.texinfo Sun Mar 20 11:18:25 2011 @@ -35,11 +35,11 @@ You can find the latest version of this manual at @url{http://common-lisp.net/project/asdf/asdf.html}. -ASDF Copyright @copyright{} 2001-2010 Daniel Barlow and contributors. +ASDF Copyright @copyright{} 2001-2011 Daniel Barlow and contributors. -This manual Copyright @copyright{} 2001-2010 Daniel Barlow and contributors. +This manual Copyright @copyright{} 2001-2011 Daniel Barlow and contributors. -This manual revised @copyright{} 2009-2010 Robert P. Goldman and Francois-Rene Rideau. +This manual revised @copyright{} 2009-2011 Robert P. Goldman and Francois-Rene Rideau. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the @@ -668,7 +668,7 @@ (defsystem "hello-lisp" :description "hello-lisp: a sample Lisp system." - :version "0.2" + :version "0.2.1" :author "Joe User " :licence "Public Domain" :components ((:file "packages") @@ -724,6 +724,19 @@ This is a good thing because the user can move the system sources without having to edit the system definition. + at c FIXME: Should have cross-reference to "Version specifiers" in the + at c defsystem grammar, but the cross-referencing is so broken by + at c insufficient node breakdown that I have not put one in. + at item +Make sure you know how the @code{:version} numbers will be parsed! They +are parsed as period-separated lists of integers. I.e., in the example, + at code{0.2.1} is to be interpreted, roughly speaking, as @code{(0 2 1)}. +In particular, version @code{0.2.1} is interpreted the same as + at code{0.0002.1} and is strictly version-less-than version @code{0.20.1}, +even though the two are the same when interpreted as decimal fractions. + at cindex version specifiers + at cindex :version + @end itemize @node A more involved example, The defsystem grammar, The defsystem form, Defining systems with defsystem @@ -735,7 +748,7 @@ @lisp (defsystem "foo" - :version "1.0" + :version "1.0.0" :components ((:module "mod" :components ((:file "bar") (:file"baz") @@ -853,7 +866,6 @@ @end example - @subsection Component names Component names (@code{simple-component-name}) @@ -954,6 +966,22 @@ on the other hand, you can circumvent the file type that would otherwise be forced upon you if you were specifying a string. + at subsection Version specifiers + at cindex version specifiers + at cindex :version + +Version specifiers are parsed as period-separated lists of integers. I.e., in the example, + at code{0.2.1} is to be interpreted, roughly speaking, as @code{(0 2 1)}. +In particular, version @code{0.2.1} is interpreted the same as + at code{0.0002.1} and is strictly version-less-than version @code{0.20.1}, +even though the two are the same when interpreted as decimal fractions. + +System definers are encouraged to use version identifiers of the form + at var{x}. at var{y}. at var{z} for major version, minor version (compatible +API) and patch level. + + at xref{Common attributes of components}. + @subsection Warning about logical pathnames @cindex logical pathnames @@ -1392,17 +1420,23 @@ @xref{The defsystem grammar,,Pathname specifiers}. @subsubsection Version identifier + at findex version-satisfies + at cindex :version -This optional attribute is used by the @code{test-system-version} operation. - at xref{Predefined operations of ASDF}. -For the default method of @code{test-system-version}, +This optional attribute is used by the generic function + at code{version-satisfies}, which tests to see if @code{:version} +dependencies are satisfied. the version should be a string of integers separated by dots, for example @samp{1.0.11}. +For more information on the semantics of version specifiers, see @ref{The defsystem grammar}. + + at c This optional attribute is intended to be used by the @code{test-system-version} operation. + at c @xref{Predefined operations of ASDF}. + at c @emph{Nota Bene}: + at c This operation, planned for ASDF 1, + at c is still not implemented yet as of ASDF 2. + at c Don't hold your breath. - at emph{Nota Bene}: -This operation, planned for ASDF 1, -is still not implement yet as of ASDF 2. -Don't hold your breath. @subsubsection Required features @@ -1509,6 +1543,14 @@ I'm sure they'd welcome your fixes. @c Doesn't CLISP now support LIST method combination? +See the discussion of the semantics of @code{:version} in the defsystem +grammar. + + at c FIXME: Should have cross-reference to "Version specifiers" in the + at c defsystem grammar, but the cross-referencing is so broken by + at c insufficient node breakdown that I have not put one in. + + @subsubsection pathname This attribute is optional and if absent (which is the usual case), @@ -2351,7 +2393,7 @@ RELATIVE-COMPONENT-DESIGNATOR := STRING | ;; namestring, directory is assumed. If the last component, /**/*.* is added - PATHNAME | ;; pathname unless last component, directory is assumed. + PATHNAME | ;; pathname; unless last component, directory is assumed. :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.45-linux-amd64 :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl :*/ | ;; any direct subdirectory (since ASDF 2.011.4) @@ -2660,24 +2702,54 @@ ASDF includes several additional features that are generally useful for system definition and development. These include: + at defun coerce-pathname name @&key type defaults + +This function takes an argument, and portably interprets it as a pathname. +If the argument @var{name} is a pathname or @code{nil}, it is passed through; +if it's a symbol, it's interpreted as a string by downcasing it; +if it's a string, it is first separated using @code{/} into substrings; +the leading substrings denote subdirectories of a relative pathname. +If @var{type} is @code{:directory} or the string ends with @code{/}, +the last substring is also a subdirectory; +if @var{type} is a string, it is used as the type of the pathname, and +the last substring is the name component of the pathname; +if @var{type} is @code{nil}, the last substring specifies both name and type components +of the pathname, with the last @code{.} separating them, or only the name component +if there's no last @code{.} or if there is only one dot and it's the first character. +The host, device and version components come from @var{defaults}, which defaults to + at var{*default-pathname-defaults*}; but that shouldn't matter if you use @code{merge-pathnames*}. + + at end defun + + at defun merge-pathnames* @&key specified defaults + +This function is a replacement for @code{merge-pathnames} that uses the host and device +from the @var{defaults} rather than the @var{specified} pathname when the latter +is a relative pathname. This allows ASDF and its users to create and use relative pathnames +without having to know beforehand what are the host and device +of the absolute pathnames they are relative to. + + at end defun + @defun system-relative-pathname system name @&key type It's often handy to locate a file relative to some system. The @code{system-relative-pathname} function meets this need. -It takes two arguments: the name of a system and a relative pathname. -It returns a pathname built from the location of the system's source file -and the relative pathname. For example + +It takes two mandatory arguments @var{system} and @var{name} +and a keyword argument @var{type}: + at var{system} is name of a system, whereas @var{name} and optionally @var{type} +specify a relative pathname, interpreted like a component pathname specifier +by @code{coerce-pathname}. @xref{The defsystem grammar,,Pathname specifiers}. + +It returns a pathname built from the location of the system's +source directory and the relative pathname. For example: @lisp -> (asdf:system-relative-pathname 'cl-ppcre #p"regex.data") +> (asdf:system-relative-pathname 'cl-ppcre "regex.data") #P"/repository/other/cl-ppcre/regex.data" @end lisp -Instead of a pathname, you can provide a symbol or a string, -and optionally a keyword argument @code{type}. -The arguments will then be interpreted in the same way -as pathname specifiers for components. - at xref{The defsystem grammar,,Pathname specifiers}. @end defun @defun system-source-directory system-designator @@ -2799,8 +2871,8 @@ ASDF 2 implements its own portable syntax for strings as pathname specifiers. Naming files within a system definition becomes easy and portable again. @xref{Miscellaneous additional functionality,asdf:system-relative-pathname}, - at code{asdf-utilities:merge-pathnames*}, - at code{asdf::merge-component-name-type}. + at code{merge-pathnames*}, + at code{coerce-pathname}. On the other hand, there are places where systems used to accept namestrings where you must now use an explicit pathname object: @@ -3051,7 +3123,7 @@ @code{(defmethod source-file-type ((component cl-source-file) (system (eql (find-system 'foo)))) (declare (ignorable component system)) "cl")}. Now, the pathname for a component is eagerly computed when defining the system, -and instead you will @code{(defclass my-cl-source-file (cl-source-file) ((type :iniform "cl")))} +and instead you will @code{(defclass my-cl-source-file (cl-source-file) ((type :initform "cl")))} and use @code{:default-component-class my-cl-source-file} as argument to @code{defsystem}, as detailed in a @pxref{FAQ,How do I create a system definition where all the source files have a .cl extension?} below. Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Sun Mar 20 11:18:25 2011 @@ -1,5 +1,5 @@ -;;; -*- mode: common-lisp; package: asdf; -*- -;;; This is ASDF: Another System Definition Facility. +;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- +;;; This is ASDF 2.013: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . @@ -10,9 +10,9 @@ ;;; trouble using it, or find bugs, you may want to check at the ;;; location above for a more recent version (and for documentation ;;; and test files, if your copy came without them) before reporting -;;; bugs. There are usually two "supported" revisions - the git HEAD -;;; is the latest development version, whereas the revision tagged -;;; RELEASE may be slightly older but is considered `stable' +;;; bugs. There are usually two "supported" revisions - the git master +;;; branch is the latest development version, whereas the git release +;;; branch may be slightly older but is considered `stable' ;;; -- LICENSE START ;;; (This is the MIT / X Consortium license as taken from @@ -47,7 +47,7 @@ #+xcvb (module ()) -(cl:in-package :cl-user) +(cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user) #+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this @@ -55,14 +55,16 @@ ;;; make package if it doesn't exist yet. ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. (unless (find-package :asdf) - (make-package :asdf :use '(:cl))) + (make-package :asdf :use '(:common-lisp))) ;;; Implementation-dependent tweaks ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults. #+allegro (setf excl::*autoload-package-name-alist* (remove "asdf" excl::*autoload-package-name-alist* :test 'equalp :key 'car)) - #+ecl (require :cmp)) + #+(and ecl (not ecl-bytecmp)) (require :cmp) + #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*) + #+(or unix cygwin) (pushnew :asdf-unix *features*)) (in-package :asdf) @@ -76,25 +78,33 @@ (let* (;; For bug reporting sanity, please always bump this version when you modify this file. ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version ;; can help you do these changes in synch (look at the source for documentation). + ;; Relying on its automation, the version is now redundantly present on top of this file. ;; "2.345" would be an official release ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.012") + (asdf-version "2.013") (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* - "~&~@<; ~@;Upgrading ASDF package ~@[from version ~A ~]to version ~A~@:>~%" + "~&; Upgrading ASDF package ~@[from version ~A ~]to version ~A~%" existing-version asdf-version)) (labels - ((unlink-package (package) + ((present-symbol-p (symbol package) + (member (nth-value 1 (find-symbol symbol package)) '(:internal :external))) + (present-symbols (package) + ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera + (let (l) + (do-symbols (s package) + (when (present-symbol-p s package) (push s l))) + (reverse l))) + (unlink-package (package) (let ((u (find-package package))) (when u - (ensure-unintern u - (loop :for s :being :each :present-symbol :in u :collect s)) + (ensure-unintern u (present-symbols u)) (loop :for p :in (package-used-by-list u) :do (unuse-package u p)) (delete-package u)))) @@ -148,7 +158,7 @@ (let ((formerly-exported-symbols nil) (bothly-exported-symbols nil) (newly-exported-symbols nil)) - (loop :for sym :being :each :external-symbol :in package :do + (do-external-symbols (sym package) (if (member sym export :test 'string-equal) (push sym bothly-exported-symbols) (push sym formerly-exported-symbols))) @@ -186,7 +196,8 @@ (#:perform #:explain #:output-files #:operation-done-p #:perform-with-restarts #:component-relative-pathname #:system-source-file #:operate #:find-component #:find-system - #:apply-output-translations #:translate-pathname* #:resolve-location) + #:apply-output-translations #:translate-pathname* #:resolve-location + #:compile-file*) :unintern (#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector @@ -278,6 +289,7 @@ #:remove-entry-from-registry #:clear-configuration + #:*output-translations-parameter* #:initialize-output-translations #:disable-output-translations #:clear-output-translations @@ -287,6 +299,7 @@ #:compile-file-pathname* #:enable-asdf-binary-locations-compatibility #:*default-source-registries* + #:*source-registry-parameter* #:initialize-source-registry #:compute-source-registry #:clear-source-registry @@ -308,6 +321,7 @@ ;; #:length=n-p ;; #:find-symbol* #:merge-pathnames* + #:coerce-pathname #:pathname-directory-pathname #:read-file-forms ;; #:remove-keys @@ -319,6 +333,7 @@ #:subdirectories #:truenamize #:while-collecting))) + #+genera (import 'scl:boolean :asdf) (setf *asdf-version* asdf-version *upgraded-p* (if existing-version (cons existing-version *upgraded-p*) @@ -330,7 +345,7 @@ (defun asdf-version () "Exported interface to the version of ASDF currently installed. A string. You can compare this string with e.g.: -(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.000\")." +(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.013\")." *asdf-version*) (defvar *resolve-symlinks* t @@ -405,6 +420,41 @@ (when pathname (make-pathname :name nil :type nil :version nil :defaults pathname))) +(defun* normalize-pathname-directory-component (directory) + (cond + #-(or sbcl cmu) + ((stringp directory) `(:absolute ,directory) directory) + #+gcl + ((and (consp directory) (stringp (first directory))) + `(:absolute , at directory)) + ((or (null directory) + (and (consp directory) (member (first directory) '(:absolute :relative)))) + directory) + (t + (error "Unrecognized pathname directory component ~S" directory)))) + +(defun* merge-pathname-directory-components (specified defaults) + (let ((directory (normalize-pathname-directory-component specified))) + (ecase (first directory) + ((nil) defaults) + (:absolute specified) + (:relative + (let ((defdir (normalize-pathname-directory-component defaults)) + (reldir (cdr directory))) + (cond + ((null defdir) + directory) + ((not (eq :back (first reldir))) + (append defdir reldir)) + (t + (loop :with defabs = (first defdir) + :with defrev = (reverse (rest defdir)) + :while (and (eq :back (car reldir)) + (or (and (eq :absolute defabs) (null defrev)) + (stringp (car defrev)))) + :do (pop reldir) (pop defrev) + :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) + (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS. @@ -413,19 +463,7 @@ (when (null defaults) (return-from merge-pathnames* specified)) (let* ((specified (pathname specified)) (defaults (pathname defaults)) - (directory (pathname-directory specified)) - (directory - (cond - #-(or sbcl cmu scl) - ((stringp directory) `(:absolute ,directory) directory) - #+gcl - ((and (consp directory) (not (member (first directory) '(:absolute :relative)))) - `(:relative , at directory)) - ((or (null directory) - (and (consp directory) (member (first directory) '(:absolute :relative)))) - directory) - (t - (error "Unrecognized directory component ~S in pathname ~S" directory specified)))) + (directory (normalize-pathname-directory-component (pathname-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)))) @@ -435,28 +473,30 @@ (if (typep p 'logical-pathname) #'ununspecific #'identity))) (multiple-value-bind (host device directory unspecific-handler) (ecase (first directory) - ((nil) - (values (pathname-host defaults) - (pathname-device defaults) - (pathname-directory defaults) - (unspecific-handler defaults))) ((:absolute) (values (pathname-host specified) (pathname-device specified) directory (unspecific-handler specified))) - ((:relative) + ((nil :relative) (values (pathname-host defaults) (pathname-device defaults) - (if (pathname-directory defaults) - (append (pathname-directory defaults) (cdr directory)) - directory) + (merge-pathname-directory-components directory (pathname-directory defaults)) (unspecific-handler defaults)))) (make-pathname :host host :device device :directory directory :name (funcall unspecific-handler name) :type (funcall unspecific-handler type) :version (funcall unspecific-handler version)))))) +(defun* pathname-parent-directory-pathname (pathname) + "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, +and NIL NAME, TYPE and VERSION components" + (when pathname + (make-pathname :name nil :type nil :version nil + :directory (merge-pathname-directory-components '(:relative :back) (pathname-directory pathname)) + :defaults pathname))) + + (define-modify-macro appendf (&rest args) append "Append onto list") ;; only to be used on short lists. @@ -469,9 +509,15 @@ (defun* last-char (s) (and (stringp s) (plusp (length s)) (char s (1- (length s))))) +(defun* errfmt (out format-string &rest format-args) + (declare (dynamic-extent format-args)) + (apply #'format out + #-genera (format nil "~~@<~A~~:>" format-string) #+genera format-string + format-args)) + (defun* asdf-message (format-string &rest format-args) (declare (dynamic-extent format-args)) - (apply #'format *verbose-out* format-string format-args)) + (apply #'errfmt *verbose-out* format-string format-args)) (defun* split-string (string &key max (separator '(#\Space #\Tab))) "Split STRING into a list of components separated by @@ -498,7 +544,7 @@ ;; Giving :unspecific as argument to make-pathname is not portable. ;; See CLHS make-pathname and 19.2.2.2.3. ;; We only use it on implementations that support it. - (or #+(or ccl gcl lispworks sbcl) :unspecific))) + (or #+(or clozure gcl lispworks sbcl) :unspecific))) (destructuring-bind (name &optional (type unspecific)) (split-string filename :max 2 :separator ".") (if (equal name "") @@ -535,7 +581,8 @@ (values :absolute (cdr components))) (values :relative nil)) (values :relative components)) - (setf components (remove "" components :test #'equal)) + (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components)) + (setf components (substitute :back ".." components :test #'equal)) (cond ((equal last-comp "") (values relative components nil)) ; "" already removed @@ -555,16 +602,27 @@ :unless (eq k key) :append (list k v))) +#+mcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (ccl:define-entry-point (_getenv "getenv") ((name :string)) :string)) + (defun* getenv (x) - (#+(or abcl clisp) ext:getenv - #+allegro sys:getenv - #+clozure ccl:getenv - #+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=))) - #+ecl si:getenv - #+gcl system:getenv - #+lispworks lispworks:environment-variable - #+sbcl sb-ext:posix-getenv - x)) + (declare (ignorable x)) + #+(or abcl clisp) (ext:getenv x) + #+allegro (sys:getenv x) + #+clozure (ccl:getenv x) + #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=)) + #+ecl (si:getenv x) + #+gcl (system:getenv x) + #+genera nil + #+lispworks (lispworks:environment-variable x) + #+mcl (ccl:with-cstrs ((name x)) + (let ((value (_getenv name))) + (unless (ccl:%null-ptr-p value) + (ccl:%get-cstring value)))) + #+sbcl (sb-ext:posix-getenv x) + #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl) + (error "getenv not available on your implementation")) (defun* directory-pathname-p (pathname) "Does PATHNAME represent a directory? @@ -602,6 +660,11 @@ :name nil :type nil :version nil :defaults pathspec)))) +#+genera +(unless (fboundp 'ensure-directories-exist) + (defun ensure-directories-exist (path) + (fs:create-directories-recursively (pathname path)))) + (defun* absolute-pathname-p (pathspec) (and (typep pathspec '(or pathname string)) (eq :absolute (car (pathname-directory (pathname pathspec)))))) @@ -629,7 +692,7 @@ :until (eq form eof) :collect form))) -#-(and (or win32 windows mswindows mingw32) (not cygwin)) +#+asdf-unix (progn #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601) '(ffi:clines "#include " "#include ")) @@ -669,13 +732,13 @@ (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) `(ignore-errors (,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" (block nil - (when (typep p 'logical-pathname) (return p)) + (when (typep p '(or null logical-pathname)) (return p)) (let* ((p (merge-pathnames* p)) (directory (pathname-directory p))) (when (typep p 'logical-pathname) (return p)) @@ -707,7 +770,9 @@ (defun* resolve-symlinks (path) #-allegro (truenamize path) - #+allegro (excl:pathname-resolve-symbolic-links path)) + #+allegro (if (typep path 'logical-pathname) + path + (excl:pathname-resolve-symbolic-links path))) (defun* default-directory () (truenamize (pathname-directory-pathname *default-pathname-defaults*))) @@ -727,17 +792,20 @@ (defun* wilden (path) (merge-pathnames* *wild-path* path)) +(defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) + (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname))) + (last-char (namestring foo)))) + (defun* directorize-pathname-host-device (pathname) (let* ((root (pathname-root pathname)) (wild-root (wilden root)) (absolute-pathname (merge-pathnames* pathname root)) - (foo (make-pathname :directory '(:absolute "FOO") :defaults root)) - (separator (last-char (namestring foo))) + (separator (directory-separator-for-host root)) (root-namestring (namestring root)) (root-string (substitute-if #\/ - (lambda (x) (or (eql x #\:) - (eql x separator))) + #'(lambda (x) (or (eql x #\:) + (eql x separator))) root-namestring))) (multiple-value-bind (relative path filename) (component-name-to-pathname-components root-string :force-directory t) @@ -856,20 +924,13 @@ ;;;; ------------------------------------------------------------------------- ;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687 (when *upgraded-p* - #+ecl - (when (find-class 'compile-op nil) - (defmethod update-instance-for-redefined-class :after - ((c compile-op) added deleted plist &key) - (declare (ignore added deleted)) - (let ((system-p (getf plist 'system-p))) - (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))) (when (find-class 'module nil) (eval `(defmethod update-instance-for-redefined-class :after ((m module) added deleted plist &key) (declare (ignorable deleted plist)) (when (or *asdf-verbose* *load-verbose*) - (asdf-message "~&~@<; ~@; Updating ~A for ASDF ~A~@:>~%" m ,(asdf-version))) + (asdf-message "~&; Updating ~A for ASDF ~A~%" m ,(asdf-version))) (when (member 'components-by-name added) (compute-module-components-by-name m)) (when (typep m 'system) @@ -897,7 +958,10 @@ duplicate-names-name error-component error-operation module-components module-components-by-name - circular-dependency-components) + circular-dependency-components + condition-arguments condition-form + condition-format condition-location + coerce-name) (ftype (function (t t) t) (setf module-components-by-name))) @@ -905,26 +969,26 @@ ((format-control :initarg :format-control :reader format-control) (format-arguments :initarg :format-arguments :reader format-arguments)) (:report (lambda (c s) - (apply #'format s (format-control c) (format-arguments c))))) + (apply #'errfmt s (format-control c) (format-arguments c))))) (define-condition load-system-definition-error (system-definition-error) ((name :initarg :name :reader error-name) (pathname :initarg :pathname :reader error-pathname) (condition :initarg :condition :reader error-condition)) (:report (lambda (c s) - (format s "~@" - (error-name c) (error-pathname c) (error-condition c))))) + (errfmt s "Error while trying to load definition for system ~A from pathname ~A: ~A" + (error-name c) (error-pathname c) (error-condition c))))) (define-condition circular-dependency (system-definition-error) ((components :initarg :components :reader circular-dependency-components)) (:report (lambda (c s) - (format s "~@" (circular-dependency-components c))))) + (errfmt s "Circular dependency: ~S" (circular-dependency-components c))))) (define-condition duplicate-names (system-definition-error) ((name :initarg :name :reader duplicate-names-name)) (:report (lambda (c s) - (format s "~@" - (duplicate-names-name c))))) + (errfmt s "Error while defining system: multiple components are given same name ~A" + (duplicate-names-name c))))) (define-condition missing-component (system-definition-error) ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) @@ -944,8 +1008,8 @@ ((component :reader error-component :initarg :component) (operation :reader error-operation :initarg :operation)) (:report (lambda (c s) - (format s "~@" - (error-operation c) (error-component c))))) + (errfmt s "erred while invoking ~A on ~A" + (error-operation c) (error-component c))))) (define-condition compile-error (operation-error) ()) (define-condition compile-failed (compile-error) ()) (define-condition compile-warned (compile-error) ()) @@ -956,22 +1020,25 @@ (format :reader condition-format :initarg :format) (arguments :reader condition-arguments :initarg :arguments :initform nil)) (:report (lambda (c s) - (format s "~@<~? (will be skipped)~@:>" - (condition-format c) - (list* (condition-form c) (condition-location c) - (condition-arguments c)))))) + (errfmt s "~? (will be skipped)" + (condition-format c) + (list* (condition-form c) (condition-location c) + (condition-arguments c)))))) (define-condition invalid-source-registry (invalid-configuration warning) - ((format :initform "~@"))) + ((format :initform "invalid source registry ~S~@[ in ~S~]~@{ ~@?~}"))) (define-condition invalid-output-translation (invalid-configuration warning) - ((format :initform "~@"))) + ((format :initform "invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}"))) (defclass component () ((name :accessor component-name :initarg :name :documentation "Component name: designator for a string composed of portable pathname characters") (version :accessor component-version :initarg :version) - ;; 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 + (description :accessor component-description :initarg :description) + (long-description :accessor component-long-description :initarg :long-description) + ;; This one below is used by POIU - http://www.cliki.net/poiu + ;; a parallelizing extension of ASDF that compiles in multiple parallel + ;; slave processes (forked on demand) and loads in the master process. + ;; Maybe in the future ASDF may use it internally instead of in-order-to. (load-dependencies :accessor component-load-dependencies :initform nil) ;; In the ASDF object model, dependencies exist between *actions* ;; (an action is a pair of operation and component). They are represented @@ -990,6 +1057,7 @@ ;; 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! + ;; See our ASDF 2 paper for more complete explanations. (in-order-to :initform nil :initarg :in-order-to :accessor component-in-order-to) (do-first :initform nil :initarg :do-first @@ -1017,13 +1085,13 @@ (defmethod print-object ((c component) stream) (print-unreadable-object (c stream :type t :identity nil) - (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c)))) + (format stream "~{~S~^ ~}" (component-find-path c)))) ;;;; methods: conditions (defmethod print-object ((c missing-dependency) s) - (format s "~@<~A, required by ~A~@:>" + (format s "~A, required by ~A" (call-next-method c nil) (missing-required-by c))) (defun* sysdef-error (format &rest arguments) @@ -1033,13 +1101,13 @@ ;;;; methods: components (defmethod print-object ((c missing-component) s) - (format s "~@" + (format s "component ~S not found~@[ in ~A~]" (missing-requires c) (when (missing-parent c) (coerce-name (missing-parent c))))) (defmethod print-object ((c missing-component-of-version) s) - (format s "~@" + (format s "component ~S does not match version ~A~@[ in ~A~]" (missing-requires c) (missing-version c) (when (missing-parent c) @@ -1116,9 +1184,10 @@ new-value) (defclass system (module) - ((description :accessor system-description :initarg :description) - (long-description - :accessor system-long-description :initarg :long-description) + (;; description and long-description are now available for all component's, + ;; but now also inherited from component, but we add the legacy accessor + (description :accessor system-description :initarg :description) + (long-description :accessor system-long-description :initarg :long-description) (author :accessor system-author :initarg :author) (maintainer :accessor system-maintainer :initarg :maintainer) (licence :accessor system-licence :initarg :licence @@ -1167,7 +1236,7 @@ (component (component-name name)) (symbol (string-downcase (symbol-name name))) (string name) - (t (sysdef-error "~@" name)))) + (t (sysdef-error "invalid component designator ~A" name)))) (defun* system-registered-p (name) (gethash (coerce-name name) *defined-systems*)) @@ -1185,11 +1254,11 @@ FN should be a function of one argument. It will be called with an object of type asdf:system." - (maphash (lambda (_ datum) - (declare (ignore _)) - (destructuring-bind (_ . def) datum + (maphash #'(lambda (_ datum) (declare (ignore _)) - (funcall fn def))) + (destructuring-bind (_ . def) datum + (declare (ignore _)) + (funcall fn def))) *defined-systems*)) ;;; for the sake of keeping things reasonably neat, we adopt a @@ -1201,7 +1270,7 @@ (defun* system-definition-pathname (system) (let ((system-name (coerce-name system))) (or - (some (lambda (x) (funcall x system-name)) + (some #'(lambda (x) (funcall x system-name)) *system-definition-search-functions*) (let ((system-pair (system-registered-p system-name))) (and system-pair @@ -1230,15 +1299,15 @@ :defaults defaults :version :newest :case :local :name name :type "asd"))) - (when (probe-file file) + (when (probe-file* file) (return file))) - #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp)) + #+(and asdf-windows (not clisp)) (let ((shortcut (make-pathname :defaults defaults :version :newest :case :local :name (concatenate 'string name ".asd") :type "lnk"))) - (when (probe-file shortcut) + (when (probe-file* shortcut) (let ((target (parse-windows-shortcut shortcut))) (when target (return (pathname target))))))))) @@ -1260,8 +1329,8 @@ (restart-case (let* ((*print-circle* nil) (message - (format nil - "~@" + (errfmt nil + "While searching for system ~S: ~S evaluated to ~S which is not a directory." system dir defaults))) (error message)) (remove-entry-from-registry () @@ -1269,8 +1338,8 @@ (push dir to-remove)) (coerce-entry-to-directory () :report (lambda (s) - (format s "Coerce entry to ~a, replace ~a and continue." - (ensure-directory-pathname defaults) dir)) + (errfmt s "Coerce entry to ~a, replace ~a and continue." + (ensure-directory-pathname defaults) dir)) (push (cons dir (ensure-directory-pathname defaults)) to-replace)))))))) ;; cleanup (dolist (dir to-remove) @@ -1302,7 +1371,7 @@ ;; and we can survive and we will continue the planning ;; as if the file were very old. ;; (or should we treat the case in a different, special way?) - (or (and pathname (probe-file pathname) (file-write-date pathname)) + (or (and pathname (probe-file* pathname) (file-write-date pathname)) (progn (when (and pathname *asdf-verbose*) (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero." @@ -1317,13 +1386,13 @@ (let ((package (make-temporary-package))) (unwind-protect (handler-bind - ((error (lambda (condition) - (error 'load-system-definition-error - :name name :pathname pathname - :condition condition)))) + ((error #'(lambda (condition) + (error 'load-system-definition-error + :name name :pathname pathname + :condition condition)))) (let ((*package* package)) (asdf-message - "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%" + "~&; Loading system definition from ~A into ~A~%" pathname package) (load pathname))) (delete-package package)))) @@ -1349,7 +1418,7 @@ (error 'missing-component :requires name))))))) (defun* register-system (name system) - (asdf-message "~&~@<; ~@;Registering ~A as ~A~@:>~%" system name) + (asdf-message "~&; Registering ~A as ~A~%" system name) (setf (gethash (coerce-name name) *defined-systems*) (cons (get-universal-time) system))) @@ -1428,6 +1497,20 @@ (source-file-explicit-type component)) (defun* merge-component-name-type (name &key type defaults) + ;; For backwards compatibility only, for people using internals. + ;; Will be removed in a future release, e.g. 2.014. + (coerce-pathname name :type type :defaults defaults)) + +(defun* coerce-pathname (name &key type defaults) + "coerce NAME into a PATHNAME. +When given a string, portably decompose it into a relative pathname: +#\\/ separates subdirectories. The last #\\/-separated string is as follows: +if TYPE is NIL, its last #\\. if any separates name and type from from type; +if TYPE is a string, it is the type, and the whole string is the name; +if TYPE is :DIRECTORY, the string is a directory component; +if the string is empty, it's a directory. +Any directory named .. is read as :BACK. +Host, device and version components are taken from DEFAULTS." ;; The defaults are required notably because they provide the default host ;; to the below make-pathname, which may crucially matter to people using ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames. @@ -1436,10 +1519,10 @@ ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of ;; ASDF:MERGE-PATHNAMES* (etypecase name - (pathname + ((or null pathname) name) (symbol - (merge-component-name-type (string-downcase name) :type type :defaults defaults)) + (coerce-pathname (string-downcase name) :type type :defaults defaults)) (string (multiple-value-bind (relative path filename) (component-name-to-pathname-components name :force-directory (eq type :directory) @@ -1460,7 +1543,7 @@ :host host :device device))))))) (defmethod component-relative-pathname ((component component)) - (merge-component-name-type + (coerce-pathname (or (slot-value component 'relative-pathname) (component-name component)) :type (source-file-type component (component-system component)) @@ -1568,18 +1651,18 @@ (defmethod component-self-dependencies ((o operation) (c component)) (let ((all-deps (component-depends-on o c))) - (remove-if-not (lambda (x) - (member (component-name c) (cdr x) :test #'string=)) + (remove-if-not #'(lambda (x) + (member (component-name c) (cdr x) :test #'string=)) all-deps))) (defmethod input-files ((operation operation) (c component)) (let ((parent (component-parent c)) (self-deps (component-self-dependencies operation c))) (if self-deps - (mapcan (lambda (dep) - (destructuring-bind (op name) dep - (output-files (make-instance op) - (find-component parent name)))) + (mapcan #'(lambda (dep) + (destructuring-bind (op name) dep + (output-files (make-instance op) + (find-component parent name)))) self-deps) ;; no previous operations needed? I guess we work with the ;; original source file, then @@ -1633,8 +1716,8 @@ ;; than one second of filesystem time (or just crosses the ;; second). So that's cool. (and - (every #'probe-file in-files) - (every #'probe-file out-files) + (every #'probe-file* in-files) + (every #'probe-file* out-files) (>= (earliest-out) (latest-in)))))))) @@ -1681,13 +1764,13 @@ required-op required-c required-v)) (retry () :report (lambda (s) - (format s "~@" required-c)) + (errfmt s "Retry loading component ~S." required-c)) :test (lambda (c) - (or (null c) - (and (typep c 'missing-dependency) - (equalp (missing-requires c) - required-c)))))))) + (or (null c) + (and (typep c 'missing-dependency) + (equalp (missing-requires c) + required-c)))))))) (defun* do-dep (operation c collect op dep) ;; type of arguments uncertain: @@ -1850,7 +1933,7 @@ (defmethod perform ((operation operation) (c source-file)) (sysdef-error - "~@" + "required method PERFORM not implemented for operation ~A, component ~A" (class-of operation) (class-of c))) (defmethod perform ((operation operation) (c module)) @@ -1873,7 +1956,7 @@ (on-failure :initarg :on-failure :accessor operation-on-failure :initform *compile-file-failure-behaviour*) (flags :initarg :flags :accessor compile-op-flags - :initform #-ecl nil #+ecl '(:system-p t)))) + :initform nil))) (defun output-file (operation component) "The unique output file of performing OPERATION on COMPONENT" @@ -1882,25 +1965,18 @@ (first files))) (defmethod perform :before ((operation compile-op) (c source-file)) - (map nil #'ensure-directories-exist (output-files operation c))) - -#+ecl -(defmethod perform :after ((o compile-op) (c cl-source-file)) - ;; Note how we use OUTPUT-FILES to find the binary locations - ;; This allows the user to override the names. - (let* ((files (output-files o c)) - (object (first files)) - (fasl (second files))) - (c:build-fasl fasl :lisp-files (list object)))) + (loop :for file :in (asdf:output-files operation c) + :for pathname = (if (typep file 'logical-pathname) + (translate-logical-pathname file) + file) + :do (ensure-directories-exist pathname))) (defmethod perform :after ((operation operation) (c component)) (setf (gethash (type-of operation) (component-operation-times c)) (get-universal-time))) -(declaim (ftype (function ((or pathname string) - &rest t &key (:output-file t) &allow-other-keys) - (values t t t)) - compile-file*)) +(defvar *compile-op-compile-file-function* 'compile-file* + "Function used to compile lisp files.") ;;; perform is required to check output-files to find out where to put ;;; its answers, in case it has been overridden for site policy @@ -1913,19 +1989,19 @@ (*compile-file-warnings-behaviour* (operation-on-warnings operation)) (*compile-file-failure-behaviour* (operation-on-failure operation))) (multiple-value-bind (output warnings-p failure-p) - (apply #'compile-file* source-file :output-file output-file + (apply *compile-op-compile-file-function* source-file :output-file output-file (compile-op-flags operation)) (when warnings-p (case (operation-on-warnings operation) (:warn (warn - "~@" + "COMPILE-FILE warned while performing ~A on ~A." operation c)) (:error (error 'compile-warned :component c :operation operation)) (:ignore nil))) (when failure-p (case (operation-on-failure operation) (:warn (warn - "~@" + "COMPILE-FILE failed while performing ~A on ~A." operation c)) (:error (error 'compile-failed :component c :operation operation)) (:ignore nil))) @@ -1935,10 +2011,8 @@ (defmethod output-files ((operation compile-op) (c cl-source-file)) (declare (ignorable operation)) (let ((p (lispize-pathname (component-pathname c)))) - #-:broken-fasl-loader - (list (compile-file-pathname p #+ecl :type #+ecl :object) - #+ecl (compile-file-pathname p :type :fasl)) - #+:broken-fasl-loader (list p))) + #-broken-fasl-loader (list (compile-file-pathname p)) + #+broken-fasl-loader (list p))) (defmethod perform ((operation compile-op) (c static-file)) (declare (ignorable operation c)) @@ -1964,11 +2038,7 @@ (defclass load-op (basic-load-op) ()) (defmethod perform ((o load-op) (c cl-source-file)) - (map () #'load - #-ecl (input-files o c) - #+ecl (loop :for i :in (input-files o c) - :unless (string= (pathname-type i) "fas") - :collect (compile-file-pathname (lispize-pathname i))))) + (map () #'load (input-files o c))) (defmethod perform-with-restarts (operation component) (perform operation component)) @@ -2061,10 +2131,10 @@ (declare (ignorable o)) (let ((what-would-load-op-do (cdr (assoc 'load-op (component-in-order-to c))))) - (mapcar (lambda (dep) - (if (eq (car dep) 'load-op) - (cons 'load-source-op (cdr dep)) - dep)) + (mapcar #'(lambda (dep) + (if (eq (car dep) 'load-op) + (cons 'load-source-op (cdr dep)) + dep)) what-would-load-op-do))) (defmethod operation-done-p ((o load-source-op) (c source-file)) @@ -2127,12 +2197,12 @@ (retry () :report (lambda (s) - (format s "~@" (operation-description op component)))) + (errfmt s "Retry ~A." (operation-description op component)))) (accept () :report (lambda (s) - (format s "~@" - (operation-description op component))) + (errfmt s "Continue, treating ~A as having been successful." + (operation-description op component))) (setf (gethash (type-of op) (component-operation-times component)) (get-universal-time)) @@ -2210,7 +2280,9 @@ ;; 3. taken from the *default-pathname-defaults* via default-directory (let* ((file-pathname (load-pathname)) (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname)))) - (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname)) + (or (and pathname-supplied-p + (merge-pathnames* (coerce-pathname pathname :type :directory) + directory-pathname)) directory-pathname (default-directory)))) @@ -2253,7 +2325,7 @@ (and (eq type :file) (or (module-default-component-class parent) (find-class *default-component-class*))) - (sysdef-error "~@" type))) + (sysdef-error "don't recognize component type ~A" type))) (defun* maybe-add-tree (tree op1 op2 c) "Add the node C at /OP1/OP2 in TREE, unless it's there already. @@ -2310,8 +2382,8 @@ ;; this is inefficient as most of the stored ;; methods will not be for this particular gf ;; But this is hardly performance-critical - (lambda (m) - (remove-method (symbol-function name) m)) + #'(lambda (m) + (remove-method (symbol-function name) m)) (component-inline-methods component))) ;; clear methods, then add the new ones (setf (component-inline-methods component) nil)) @@ -2512,7 +2584,7 @@ (defun* system-relative-pathname (system name &key type) (merge-pathnames* - (merge-component-name-type name :type type) + (coerce-pathname name :type type) (system-source-directory system))) @@ -2523,13 +2595,13 @@ ;;; Initially stolen from SLIME's SWANK, hacked since. (defparameter *implementation-features* - '((:acl :allegro) - (:lw :lispworks) - (:digitool) ; before clozure, so it won't get preempted by ccl + '((:abcl :armedbear) + (:acl :allegro) + (:mcl :digitool) ; before clozure, so it won't get preempted by ccl (:ccl :clozure) (:corman :cormanlisp) - (:abcl :armedbear) - :sbcl :cmu :clisp :gcl :ecl :scl)) + (:lw :lispworks) + :clisp :cmu :ecl :gcl :sbcl :scl :symbolics)) (defparameter *os-features* '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows @@ -2537,7 +2609,8 @@ (:linux :linux-target) ;; for GCL at least, must appear before :bsd. (:macosx :darwin :darwin-target :apple) :freebsd :netbsd :openbsd :bsd - :unix)) + :unix + :genera)) (defparameter *architecture-features* '((:amd64 :x86-64 :x86_64 :x8664-target) @@ -2549,7 +2622,8 @@ :sparc64 (:sparc32 :sparc) (:arm :arm-target) - (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7))) + (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7) + :imach)) (defun* lisp-version-string () (let ((s (lisp-implementation-version))) @@ -2567,24 +2641,26 @@ (:+ics "")) (if (member :64bit *features*) "-64bit" "")) #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) - #+clisp (subseq s 0 (position #\space s)) + #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.) #+clozure (format nil "~d.~d-f~d" ; shorten for windows ccl::*openmcl-major-version* ccl::*openmcl-minor-version* (logand ccl::fasl-version #xFF)) #+cmu (substitute #\- #\/ s) - #+digitool (subseq s 8) #+ecl (format nil "~A~@[-~A~]" s (let ((vcs-id (ext:lisp-implementation-vcs-id))) (when (>= (length vcs-id) 8) (subseq vcs-id 0 8)))) #+gcl (subseq s (1+ (position #\space s))) + #+genera (multiple-value-bind (major minor) (sct:get-system-version "System") + (format nil "~D.~D" major minor)) #+lispworks (format nil "~A~@[~A~]" s (when (member :lispworks-64bit *features*) "-64bit")) ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version - #+(or cormanlisp mcl sbcl scl) s - #-(or allegro armedbear clisp clozure cmu cormanlisp digitool - ecl gcl lispworks mcl sbcl scl) s)) + #+mcl (subseq s 8) ; strip the leading "Version " + #+(or cormanlisp sbcl scl) s + #-(or allegro armedbear clisp clozure cmu cormanlisp + ecl gcl genera lispworks mcl sbcl scl) s)) (defun* first-feature (features) (labels @@ -2616,31 +2692,31 @@ *implementation-features*)) (os (maybe-warn (first-feature *os-features*) "No os feature found in ~a." *os-features*)) - (arch #+clisp "" #-clisp - (maybe-warn (first-feature *architecture-features*) - "No architecture feature found in ~a." - *architecture-features*)) + (arch (or #-clisp + (maybe-warn (first-feature *architecture-features*) + "No architecture feature found in ~a." + *architecture-features*))) (version (maybe-warn (lisp-version-string) "Don't know how to get Lisp implementation version."))) (substitute-if - #\_ (lambda (x) (find x " /:\\(){}[]$#`'\"")) - (format nil "~(~@{~a~^-~}~)" lisp version os arch))))) + #\_ #'(lambda (x) (find x " /:\\(){}[]$#`'\"")) + (format nil "~(~a~@{~@[-~a~]~}~)" lisp version os arch))))) ;;; --------------------------------------------------------------------------- ;;; Generic support for configuration files (defparameter *inter-directory-separator* - #+(or unix cygwin) #\: - #-(or unix cygwin) #\;) + #+asdf-unix #\: + #-asdf-unix #\;) (defun* user-homedir () - (truename (user-homedir-pathname))) + (truenamize (pathname-directory-pathname (user-homedir-pathname)))) (defun* try-directory-subpath (x sub &key type) (let* ((p (and x (ensure-directory-pathname x))) (tp (and p (probe-file* p))) - (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p))) + (sp (and tp (merge-pathnames* (coerce-pathname sub :type type) p))) (ts (and sp (probe-file* sp)))) (and ts (values sp ts)))) (defun* user-configuration-directories () @@ -2651,7 +2727,7 @@ ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") :for dir :in (split-string dirs :separator ":") :collect (try dir "common-lisp/")) - #+(and (or win32 windows mswindows mingw32) (not cygwin)) + #+asdf-windows ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/") ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData ,(try (getenv "APPDATA") "common-lisp/config/")) @@ -2660,11 +2736,12 @@ (remove-if #'null (append - #+(and (or win32 windows mswindows mingw32) (not cygwin)) + #+asdf-windows (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/") ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/")))) + #+asdf-unix (list #p"/etc/common-lisp/")))) (defun* in-first-directory (dirs x) (loop :for dir :in dirs @@ -2733,7 +2810,7 @@ (defun* directory* (pathname-spec &rest keys &key &allow-other-keys) (apply 'directory pathname-spec (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) - #+ccl '(:follow-links nil) + #+clozure '(:follow-links nil) #+clisp '(:circle t :if-does-not-exist :ignore) #+(or cmu scl) '(:follow-links nil :truenamep nil) #+sbcl (when (find-symbol "RESOLVE-SYMLINKS" "SB-IMPL") '(:resolve-symlinks nil)))))) @@ -2781,7 +2858,7 @@ (flet ((try (x &rest sub) (and x `(,x , at sub)))) (or (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation) - #+(and (or win32 windows mswindows mingw32) (not cygwin)) + #+asdf-windows (try (getenv "APPDATA") "common-lisp" "cache" :implementation) '(:home ".cache" "common-lisp" :implementation)))) (defvar *system-cache* @@ -2796,12 +2873,12 @@ (setf *output-translations* (list (stable-sort (copy-list new-value) #'> - :key (lambda (x) - (etypecase (car x) - ((eql t) -1) - (pathname - (let ((directory (pathname-directory (car x)))) - (if (listp directory) (length directory) 0)))))))) + :key #'(lambda (x) + (etypecase (car x) + ((eql t) -1) + (pathname + (let ((directory (pathname-directory (car x)))) + (if (listp directory) (length directory) 0)))))))) new-value) (defun* output-translations-initialized-p () @@ -2840,7 +2917,7 @@ ((eql :*.*.*) *wild-file*) ((eql :implementation) (implementation-identifier)) ((eql :implementation-type) (string-downcase (implementation-type))) - #-(and (or win32 windows mswindows mingw32) (not cygwin)) + #+asdf-unix ((eql :uid) (princ-to-string (get-uid))))) (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r))) (s (if (or (pathnamep x) (not wilden)) d (wilden d)))) @@ -2911,7 +2988,7 @@ (typep c '(or string pathname (member :default-directory :*/ :**/ :*.*.* :implementation :implementation-type - #-(and (or win32 windows mswindows mingw32) (not cygwin)) :uid))))) + #+asdf-unix :uid))))) (or (typep x 'boolean) (absolute-component-p x) (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x)))))) @@ -3003,7 +3080,8 @@ `(:output-translations ;; Some implementations have precompiled ASDF systems, ;; so we must disable translations for implementation paths. - #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ()))) + #+sbcl ,(let ((h (getenv "SBCL_HOME"))) + (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ()))) #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system ;; All-import, here is where we want user stuff to be: @@ -3014,8 +3092,8 @@ ;; 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") -(defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/") +(defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf")) +(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/")) (defun* user-output-translations-pathname () (in-user-configuration-directory *output-translations-file* )) @@ -3043,7 +3121,7 @@ ((directory-pathname-p pathname) (process-output-translations (validate-output-translations-directory pathname) :inherit inherit :collect collect)) - ((probe-file pathname) + ((probe-file* pathname) (process-output-translations (validate-output-translations-file pathname) :inherit inherit :collect collect)) (t @@ -3106,10 +3184,13 @@ `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c)) :test 'equal :from-end t)) -(defun* initialize-output-translations (&optional parameter) +(defvar *output-translations-parameter* nil) + +(defun* initialize-output-translations (&optional (parameter *output-translations-parameter*)) "read the configuration, initialize the internal configuration variable, return the configuration" - (setf (output-translations) (compute-output-translations parameter))) + (setf *output-translations-parameter* parameter + (output-translations) (compute-output-translations parameter))) (defun* disable-output-translations () "Initialize output translations in a way that maps every file to itself, @@ -3185,7 +3266,7 @@ :defaults x)) (defun* delete-file-if-exists (x) - (when (and x (probe-file x)) + (when (and x (probe-file* x)) (delete-file x))) (defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys) @@ -3278,7 +3359,7 @@ ;;;; Jesse Hager: The Windows Shortcut File Format. ;;;; http://www.wotsit.org/list.asp?fc=13 -#+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp)) +#+(and asdf-windows (not clisp)) (progn (defparameter *link-initial-dword* 76) (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70)) @@ -3388,29 +3469,32 @@ (defun directory-has-asd-files-p (directory) (ignore-errors - (directory* (merge-pathnames* *wild-asd* directory)) - t)) + (and (directory* (merge-pathnames* *wild-asd* directory)) t))) (defun subdirectories (directory) (let* ((directory (ensure-directory-pathname directory)) - #-cormanlisp + #-(or cormanlisp genera) (wild (merge-pathnames* #-(or abcl allegro lispworks scl) *wild-directory* #+(or abcl allegro lispworks scl) "*.*" directory)) (dirs - #-cormanlisp + #-(or cormanlisp genera) (ignore-errors - (directory* wild . #.(or #+ccl '(:directories t :files nil) - #+digitool '(:directories t)))) - #+cormanlisp (cl::directory-subdirs directory)) - #+(or abcl allegro lispworks scl) + (directory* wild . #.(or #+clozure '(:directories t :files nil) + #+mcl '(:directories t)))) + #+cormanlisp (cl::directory-subdirs directory) + #+genera (fs:directory-list directory)) + #+(or abcl allegro genera 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))) + #+genera #'(lambda (x) (getf (cdr x) :directory)) + #-(or abcl allegro genera lispworks) #'directory-pathname-p + dirs)) + #+genera + (dirs (mapcar #'(lambda (x) (ensure-directory-pathname (first x))) dirs))) dirs)) (defun collect-sub*directories (directory collectp recursep collector) @@ -3505,35 +3589,35 @@ system-source-registry-directory default-source-registry)) -(defparameter *source-registry-file* #p"source-registry.conf") -(defparameter *source-registry-directory* #p"source-registry.conf.d/") +(defparameter *source-registry-file* (coerce-pathname "source-registry.conf")) +(defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/")) (defun* wrapping-source-registry () `(:source-registry - #+sbcl (:tree ,(getenv "SBCL_HOME")) + #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME"))) :inherit-configuration #+cmu (:tree #p"modules:"))) (defun* default-source-registry () (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) `(:source-registry #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir))) - (:directory ,(truenamize (directory-namestring *default-pathname-defaults*))) + (:directory ,(default-directory)) ,@(let* - #+(or unix cygwin) + #+asdf-unix ((datahome (or (getenv "XDG_DATA_HOME") (try (user-homedir) ".local/share/"))) (datadirs (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share")) (dirs (cons datahome (split-string datadirs :separator ":")))) - #+(and (or win32 windows mswindows mingw32) (not cygwin)) + #+asdf-windows ((datahome (getenv "APPDATA")) (datadir #+lispworks (sys:get-folder-path :local-appdata) #-lispworks (try (getenv "ALLUSERSPROFILE") "Application Data")) (dirs (list datahome datadir))) - #-(or unix win32 windows mswindows mingw32 cygwin) + #-(or asdf-unix asdf-windows) ((dirs ())) (loop :for dir :in dirs :collect `(:directory ,(try dir "common-lisp/systems/")) @@ -3564,7 +3648,7 @@ (let ((*here-directory* (truenamize pathname))) (process-source-registry (validate-source-registry-directory pathname) :inherit inherit :register register))) - ((probe-file pathname) + ((probe-file* pathname) (let ((*here-directory* (pathname-directory-pathname pathname))) (process-source-registry (validate-source-registry-file pathname) :inherit inherit :register register))) @@ -3620,8 +3704,8 @@ `(wrapping-source-registry ,parameter ,@*default-source-registries*) - :register (lambda (directory &key recurse exclude) - (collect (list directory :recurse recurse :exclude exclude))))) + :register #'(lambda (directory &key recurse exclude) + (collect (list directory :recurse recurse :exclude exclude))))) :test 'equal :from-end t))) ;; Will read the configuration and initialize all internal variables, @@ -3634,8 +3718,11 @@ directory :recurse recurse :exclude exclude :collect #'collect))))) -(defun* initialize-source-registry (&optional parameter) - (setf (source-registry) (compute-source-registry parameter))) +(defvar *source-registry-parameter* nil) + +(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*)) + (setf *source-registry-parameter* parameter + (source-registry) (compute-source-registry parameter))) ;; Checks an initial variable to see whether the state is initialized ;; or cleared. In the former case, return current configuration; in @@ -3668,9 +3755,9 @@ (handler-bind ((style-warning #'muffle-warning) (missing-component (constantly nil)) - (error (lambda (e) - (format *error-output* "ASDF could not load ~(~A~) because ~A.~%" - name e)))) + (error #'(lambda (e) + (errfmt *error-output* "ASDF could not load ~(~A~) because ~A.~%" + name e)))) (let* ((*verbose-out* (make-broadcast-stream)) (system (find-system (string-downcase name) nil))) (when system @@ -3694,17 +3781,6 @@ ;;;; Things to do in case we're upgrading from a previous version of ASDF. ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 ;;;; -;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1 -(eval-when (:compile-toplevel :load-toplevel :execute) - #+ecl ;; Support upgrade from before ECL went to 1.369 - (when (fboundp 'compile-op-system-p) - (defmethod compile-op-system-p ((op compile-op)) - (getf :system-p (compile-op-flags op))) - (defmethod initialize-instance :after ((op compile-op) - &rest initargs - &key system-p &allow-other-keys) - (declare (ignorable initargs)) - (when system-p (appendf (compile-op-flags op) (list :system-p system-p)))))) ;;; If a previous version of ASDF failed to read some configuration, try again. (when *ignored-configuration-form* From mevenson at common-lisp.net Sun Mar 20 20:25:05 2011 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 20 Mar 2011 16:25:05 -0400 Subject: [armedbear-cvs] r13254 - trunk/abcl/doc/design/streams Message-ID: Author: mevenson Date: Sun Mar 20 16:25:03 2011 New Revision: 13254 Log: Reformat to 80 columns Modified: trunk/abcl/doc/design/streams/design.rst Modified: trunk/abcl/doc/design/streams/design.rst ============================================================================== --- trunk/abcl/doc/design/streams/design.rst (original) +++ trunk/abcl/doc/design/streams/design.rst Sun Mar 20 16:25:03 2011 @@ -5,40 +5,51 @@ The previous design ------------------- -Previously, ABCL streams were built-in classes. This presented some problems for Gray streams, -because ABCL CLOS can't use a built-in class as a base class, and Gray streams derive from -a system-stream class. This was corrected by converting ABCL streams to be structure-objects -instead of built-in classes, allowing CLOS to derive from the streams. There was, however, another -problem that revealed a need to change the design in more drastic ways. +Previously, ABCL streams were built-in classes. This presented some +problems for Gray streams, because ABCL CLOS can't use a built-in +class as a base class, and Gray streams derive from a system-stream +class. This was corrected by converting ABCL streams to be +structure-objects instead of built-in classes, allowing CLOS to derive +from the streams. There was, however, another problem that revealed a +need to change the design in more drastic ways. The problem with the previous design ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -While converting the streams from built-in classes to structure-objects allowed derivation, -the pretty printer still didn't work with Gray streams. Gray streams replace the system stream -functions, saving the old function symbols so that they can be later invoked. The pretty printer, -however, just replaces the stream functions, and calls the low-level primitives directly, thus -bypassing Gray streams completely. The attached image portrays the problem, where pprint will, -for example, invoke %stream-write-char, thus bypassing any methods that there may be for -stream-write-char using Gray streams. +While converting the streams from built-in classes to +structure-objects allowed derivation, the pretty printer still didn't +work with Gray streams. Gray streams replace the system stream +functions, saving the old function symbols so that they can be later +invoked. The pretty printer, however, just replaces the stream +functions, and calls the low-level primitives directly, thus bypassing +Gray streams completely. The attached image portrays the problem, +where pprint will, for example, invoke %stream-write-char, thus +bypassing any methods that there may be for stream-write-char using +Gray streams. .. image:: pprint-problem.png The planned future design and solution to the problem ----------------------------------------------------- -The solution to the problem is quite similar to how SBCL does its streams. First of all, the pretty printer will -no longer replace stream functions. The stream functionality will be based on closures in the slots of -the structure-object representing the stream, and those closures will invoke low-level i/o functions that -are stream-specific. - -The pretty printer will just setup closures that will extract the underlying stream -object from a pprint-wrapped stream, and invoke its low-level functions. If pprint wrapping isn't present, -the slots will contain closures that directly invoke low-level functions of streams. Gray streams will -still replace the stream functions, because it's capable of invoking the replaced functions. - -In addition to these changes, it is planned that the stream function primitives will be moved from the Stream -java class to a streamfunctions library, allowing the stream functions to be written in lisp rather than java. -There's an ongoing aspiration to increase the lisp/java code ratio of ABCL, and this new design allows for that. +The solution to the problem is quite similar to how SBCL does its +streams. First of all, the pretty printer will no longer replace +stream functions. The stream functionality will be based on closures +in the slots of the structure-object representing the stream, and +those closures will invoke low-level i/o functions that are +stream-specific. + +The pretty printer will just setup closures that will extract the +underlying stream object from a pprint-wrapped stream, and invoke its +low-level functions. If pprint wrapping isn't present, the slots will +contain closures that directly invoke low-level functions of +streams. Gray streams will still replace the stream functions, because +it's capable of invoking the replaced functions. + +In addition to these changes, it is planned that the stream function +primitives will be moved from the Stream java class to a +streamfunctions library, allowing the stream functions to be written +in lisp rather than java. There's an ongoing aspiration to increase +the lisp/java code ratio of ABCL, and this new design allows for that. .. image:: pprint-solution.png From mevenson at common-lisp.net Sun Mar 20 20:26:04 2011 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 20 Mar 2011 16:26:04 -0400 Subject: [armedbear-cvs] r13255 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun Mar 20 16:26:04 2011 New Revision: 13255 Log: Enable our GRAY-STREAMS implementation to work with flexi-streams. With this patch, flexi-streams-1.0.7 now passes its internal tests with ABCL. NB. One must [patch TRIVIAL-GRAY-STREAMS][1] to use the new generic for FILE-POSITION for this to work. [1]: http://detroit.slack.net/~evenson/abcl/trivial-gray-streams-abcl-20110320a.patch GRAY-STREAMS:STREAM-FILE-POSITION now provides a generic function counterpart. for FILE-POSITION on a Gray stream. Fix OPEN-STREAM-P as described in the Gray streams proposal by adding a field to the FUNDAMENTAL-STREAM class whose which records whether CLOSE has been called on this stream. Fix STREAM-OUTPUT-STREAM-P and STREAM-INPUT-STREAM_P by providing default methods on FUNDAMENTAL-INPUT-STREAM and FUNDAMENTAL-OUTPUT-STREAM. Renamed all symbols old-XXXX-XXXX to the more informative ansi-XXXX-XXXX pattern. Remove export of unused symbols STREAM-OPEN-STREAM-P, STREAM-STREAMP, STREAM-INPUT-STREAM-P, STREAM-OUTPUT-STREAM-P, STREAM-STREAM-ELEMENT-TYPE, and STREAM-CLOSE which should have been removed with r12183. Modified: trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Modified: trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Sun Mar 20 16:26:04 2011 @@ -57,11 +57,26 @@ ;;;; ;;;; Notes ;;;; ===== +;;;; +;;;; NB: The ABCL implementation has been extensively reworked since these +;;;; notes were included. Please see the ABCL revision history via +;;;; the interface at +;;;; +;;;; http://trac.common-lisp.net/armedbear/browser/trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp +;;;; +;;;; for a more relevant history vis a vis the ABCL implementation. +;;;; ;;;; A simple implementation of Gray streams for Corman Lisp 1.42. ;;;; Gray streams are 'clos' based streams as described at: ;;;; ;;;; ftp://parcftp.xerox.com/pub/cl/cleanup/mail/stream-definition-by-user.mail ;;;; +;;;; 20110319 +;;;; The xerox.com ftp URI doesn't resolve. Instead see Kent Pitman's +;;;; archival copy at +;;;; +;;;; http://www.nhplace.com/kent/CL/Issues/stream-definition-by-user.html +;;;; ;;;; Some differences exist between this implementation and the ;;;; specification above. See notes below for details. ;;;; @@ -105,12 +120,6 @@ (:nicknames "GS") ;; # fb 1.01 (:export "FUNDAMENTAL-STREAM" - "STREAM-OPEN-STREAM-P" - "STREAM-STREAMP" - "STREAM-INPUT-STREAM-P" - "STREAM-OUTPUT-STREAM-P" - "STREAM-STREAM-ELEMENT-TYPE" - "STREAM-CLOSE" "FUNDAMENTAL-OUTPUT-STREAM" "FUNDAMENTAL-INPUT-STREAM" "FUNDAMENTAL-CHARACTER-STREAM" @@ -138,48 +147,52 @@ "STREAM-ADVANCE-TO-COLUMN" "STREAM-READ-SEQUENCE" "STREAM-WRITE-SEQUENCE" + "STREAM-FILE-POSITION" "FUNDAMENTAL-BINARY-INPUT-STREAM" "FUNDAMENTAL-BINARY-OUTPUT-STREAM")) (in-package :gray-streams) -(defvar *old-read-char* #'read-char) -(defvar *old-peek-char* #'peek-char) -(defvar *old-unread-char* #'unread-char) -(defvar *old-listen* nil) -(defvar *old-read-line* #'read-line) -(defvar *old-read-char-no-hang* #'read-char-no-hang) -(defvar *old-write-char* #'write-char) -(defvar *old-fresh-line* #'fresh-line) -(defvar *old-terpri* #'terpri) -(defvar *old-write-string* #'write-string) -(defvar *old-write-line* #'write-line) -(defvar *old-force-output* #'sys::%force-output) -(defvar *old-finish-output* #'sys::%finish-output) -(defvar *old-clear-output* #'sys::%clear-output) -(defvar *old-clear-input* #'clear-input) -(defvar *old-read-byte* #'read-byte) -(defvar *old-write-byte* #'write-byte) -(defvar *old-stream-element-type* #'cl::stream-element-type) -(defvar *old-close* #'cl::close) -(defvar *old-input-character-stream-p* +(defvar *ansi-read-char* #'read-char) +(defvar *ansi-peek-char* #'peek-char) +(defvar *ansi-unread-char* #'unread-char) +(defvar *ansi-listen* nil) +(defvar *ansi-read-line* #'read-line) +(defvar *ansi-read-char-no-hang* #'read-char-no-hang) +(defvar *ansi-write-char* #'write-char) +(defvar *ansi-fresh-line* #'fresh-line) +(defvar *ansi-terpri* #'terpri) +(defvar *ansi-write-string* #'write-string) +(defvar *ansi-write-line* #'write-line) +(defvar *ansi-force-output* #'sys::%force-output) +(defvar *ansi-finish-output* #'sys::%finish-output) +(defvar *ansi-clear-output* #'sys::%clear-output) +(defvar *ansi-clear-input* #'clear-input) +(defvar *ansi-read-byte* #'read-byte) +(defvar *ansi-write-byte* #'write-byte) +(defvar *ansi-stream-element-type* #'cl::stream-element-type) +(defvar *ansi-close* #'cl::close) +(defvar *ansi-input-character-stream-p* #'(lambda (s) (and (input-stream-p s) (eql (stream-element-type s) 'character)))) -(defvar *old-input-stream-p* #'cl::input-stream-p) -(defvar *old-output-stream-p* #'cl::output-stream-p) -(defvar *old-open-stream-p* #'cl::open-stream-p) -(defvar *old-streamp* #'cl::streamp) -(defvar *old-read-sequence* #'cl::read-sequence) -(defvar *old-write-sequence* #'cl::write-sequence) -(defvar *old-make-two-way-stream* #'cl:make-two-way-stream) -(defvar *old-two-way-stream-input-stream* #'cl:two-way-stream-input-stream) -(defvar *old-two-way-stream-output-stream* #'cl:two-way-stream-output-stream) +(defvar *ansi-input-stream-p* #'cl::input-stream-p) +(defvar *ansi-output-stream-p* #'cl::output-stream-p) +(defvar *ansi-open-stream-p* #'cl::open-stream-p) +(defvar *ansi-streamp* #'cl::streamp) +(defvar *ansi-read-sequence* #'cl::read-sequence) +(defvar *ansi-write-sequence* #'cl::write-sequence) +(defvar *ansi-make-two-way-stream* #'cl:make-two-way-stream) +(defvar *ansi-two-way-stream-input-stream* #'cl:two-way-stream-input-stream) +(defvar *ansi-two-way-stream-output-stream* #'cl:two-way-stream-output-stream) +(defvar *ansi-file-position* #'cl:file-position) - -(defun old-streamp (stream) +(defun ansi-streamp (stream) (or (xp::xp-structure-p stream) - (funcall *old-streamp* stream))) + (funcall *ansi-streamp* stream))) -(defclass fundamental-stream (standard-object stream)) +(defclass fundamental-stream (standard-object stream) + ((open-p :initform t + :accessor stream-open-p)) + (:documentation "The base class of all Gray streams")) (defgeneric gray-close (stream &key abort)) (defgeneric gray-open-stream-p (stream)) @@ -189,29 +202,42 @@ (defgeneric gray-output-stream-p (stream)) (defgeneric gray-stream-element-type (stream)) +(defmethod gray-close ((stream fundamental-stream) &key abort) + (declare (ignore abort)) + (setf (stream-open-p stream) nil) + t) + +(defmethod gray-open-stream-p ((stream fundamental-stream)) + (stream-open-p stream)) -(defmethod stream-streamp ((s fundamental-stream)) +(defmethod gray-streamp ((s fundamental-stream)) s) (defclass fundamental-input-stream (fundamental-stream)) -(defmethod stream-input-character-stream-p (s) ;; # fb 1.01 - (and (stream-input-stream-p s) - (eq (stream-stream-element-type s) 'character))) +(defmethod gray-input-character-stream-p (s) ;; # fb 1.01 + (and (gray-input-stream-p s) + (eq (gray-stream-element-type s) 'character))) -(defmethod stream-input-stream-p ((s fundamental-input-stream)) +(defmethod gray-input-stream-p ((s fundamental-input-stream)) (declare (ignore s)) t) (defclass fundamental-output-stream (fundamental-stream)) -(defmethod stream-output-stream-p ((s fundamental-output-stream)) +(defmethod gray-input-stream-p ((s fundamental-output-stream)) + (typep s 'fundamental-input-stream)) + +(defmethod gray-output-stream-p ((s fundamental-output-stream)) (declare (ignore s)) t) +(defmethod gray-output-stream-p ((s fundamental-input-stream)) + (typep s 'fundamental-output-stream)) + (defclass fundamental-character-stream (fundamental-stream)) -(defmethod stream-stream-element-type ((s fundamental-character-stream)) +(defmethod gray-stream-element-type ((s fundamental-character-stream)) (declare (ignore s)) 'character) @@ -382,15 +408,15 @@ (defun gray-read-char (&optional input-stream (eof-errorp t) eof-value recursive-p) (let ((stream (decode-read-arg input-stream))) - (if (old-streamp stream) - (funcall *old-read-char* stream eof-errorp eof-value recursive-p) + (if (ansi-streamp stream) + (funcall *ansi-read-char* stream eof-errorp eof-value recursive-p) (check-for-eof (stream-read-char stream) stream eof-errorp eof-value)))) (defun gray-peek-char (&optional peek-type input-stream (eof-errorp t) eof-value recursive-p) (let ((stream (decode-read-arg input-stream))) - (if (old-streamp stream) - (funcall *old-peek-char* peek-type stream eof-errorp eof-value recursive-p) + (if (ansi-streamp stream) + (funcall *ansi-peek-char* peek-type stream eof-errorp eof-value recursive-p) (if (null peek-type) (check-for-eof (stream-peek-char stream) stream eof-errorp eof-value) (loop @@ -406,21 +432,21 @@ (defun gray-unread-char (character &optional input-stream) (let ((stream (decode-read-arg input-stream))) - (if (old-streamp stream) - (funcall *old-unread-char* character stream) + (if (ansi-streamp stream) + (funcall *ansi-unread-char* character stream) (stream-unread-char stream character)))) (defun gray-listen (&optional input-stream) (let ((stream (decode-read-arg input-stream))) - (if (old-streamp stream) - (funcall *old-listen* stream) + (if (ansi-streamp stream) + (funcall *ansi-listen* stream) (stream-listen stream)))) (defun gray-read-line (&optional input-stream (eof-error-p t) eof-value recursive-p) (let ((stream (decode-read-arg input-stream))) - (if (old-streamp stream) - (funcall *old-read-line* stream eof-error-p eof-value recursive-p) + (if (ansi-streamp stream) + (funcall *ansi-read-line* stream eof-error-p eof-value recursive-p) (multiple-value-bind (string eofp) (stream-read-line stream) (if eofp @@ -431,46 +457,46 @@ (defun gray-clear-input (&optional input-stream) (let ((stream (decode-read-arg input-stream))) - (if (old-streamp stream) - (funcall *old-clear-input* stream) + (if (ansi-streamp stream) + (funcall *ansi-clear-input* stream) (stream-clear-input stream)))) (defun gray-read-char-no-hang (&optional input-stream (eof-errorp t) eof-value recursive-p) (let ((stream (decode-read-arg input-stream))) - (if (old-streamp stream) - (funcall *old-read-char-no-hang* stream eof-errorp eof-value recursive-p) + (if (ansi-streamp stream) + (funcall *ansi-read-char-no-hang* stream eof-errorp eof-value recursive-p) (check-for-eof (stream-read-char-no-hang stream) stream eof-errorp eof-value)))) (defun gray-write-char (character &optional output-stream) (let ((stream (decode-print-arg output-stream))) - (if (old-streamp stream) - (funcall *old-write-char* character stream) + (if (ansi-streamp stream) + (funcall *ansi-write-char* character stream) (stream-write-char stream character)))) (defun gray-fresh-line (&optional output-stream) (let ((stream (decode-print-arg output-stream))) - (if (old-streamp stream) - (funcall *old-fresh-line* stream) + (if (ansi-streamp stream) + (funcall *ansi-fresh-line* stream) (stream-fresh-line stream)))) (defun gray-terpri (&optional output-stream) (let ((stream (decode-print-arg output-stream))) - (if (old-streamp stream) - (funcall *old-terpri* stream) + (if (ansi-streamp stream) + (funcall *ansi-terpri* stream) (stream-terpri stream)))) (defun gray-write-string (string &optional output-stream &key (start 0) end) (let ((stream (decode-print-arg output-stream))) - (if (old-streamp stream) - (funcall *old-write-string* string stream :start start :end end) + (if (ansi-streamp stream) + (funcall *ansi-write-string* string stream :start start :end end) (stream-write-string stream string start end)))) (defun gray-write-line (string &optional output-stream &key (start 0) end) (let ((stream (decode-print-arg output-stream))) - (if (old-streamp stream) - (funcall *old-write-line* string stream :start start :end end) + (if (ansi-streamp stream) + (funcall *ansi-write-line* string stream :start start :end end) (progn (stream-write-string stream string start end) (stream-terpri stream) @@ -478,31 +504,31 @@ (defun gray-force-output (&optional output-stream) (let ((stream (decode-print-arg output-stream))) - (if (old-streamp stream) - (funcall *old-force-output* stream) + (if (ansi-streamp stream) + (funcall *ansi-force-output* stream) (stream-force-output stream)))) (defun gray-finish-output (&optional output-stream) (let ((stream (decode-print-arg output-stream))) - (if (old-streamp stream) - (funcall *old-finish-output* stream) + (if (ansi-streamp stream) + (funcall *ansi-finish-output* stream) (stream-finish-output stream)))) (defun gray-clear-output (&optional output-stream) (let ((stream (decode-print-arg output-stream))) - (if (old-streamp stream) - (funcall *old-clear-output* stream) + (if (ansi-streamp stream) + (funcall *ansi-clear-output* stream) (stream-clear-output stream)))) (defun gray-read-byte (binary-input-stream &optional (eof-errorp t) eof-value) - (if (old-streamp binary-input-stream) - (funcall *old-read-byte* binary-input-stream eof-errorp eof-value) + (if (ansi-streamp binary-input-stream) + (funcall *ansi-read-byte* binary-input-stream eof-errorp eof-value) (check-for-eof (stream-read-byte binary-input-stream) binary-input-stream eof-errorp eof-value))) (defun gray-write-byte (integer binary-output-stream) - (if (old-streamp binary-output-stream) - (funcall *old-write-byte* integer binary-output-stream) + (if (ansi-streamp binary-output-stream) + (funcall *ansi-write-byte* integer binary-output-stream) (stream-write-byte binary-output-stream integer))) (defmethod stream-line-column ((stream stream)) @@ -510,58 +536,69 @@ (defun gray-stream-column (&optional input-stream) (let ((stream (decode-read-arg input-stream))) - (if (old-streamp stream) - nil ;(funcall *old-stream-column* stream) + (if (ansi-streamp stream) + nil ;(funcall *ansi-stream-column* stream) (stream-line-column stream)))) (defmethod gray-stream-element-type (stream) - (funcall *old-stream-element-type* stream)) + (funcall *ansi-stream-element-type* stream)) (defmethod gray-close (stream &key abort) - (funcall *old-close* stream :abort abort)) + (funcall *ansi-close* stream :abort abort)) (defmethod gray-input-stream-p (stream) - (funcall *old-input-stream-p* stream)) + (funcall *ansi-input-stream-p* stream)) (defmethod gray-input-character-stream-p (stream) - (funcall *old-input-character-stream-p* stream)) + (funcall *ansi-input-character-stream-p* stream)) (defmethod gray-output-stream-p (stream) - (funcall *old-output-stream-p* stream)) + (funcall *ansi-output-stream-p* stream)) (defmethod gray-open-stream-p (stream) - (funcall *old-open-stream-p* stream)) + (funcall *ansi-open-stream-p* stream)) (defmethod gray-streamp (stream) - (funcall *old-streamp* stream)) + (funcall *ansi-streamp* stream)) (defun gray-write-sequence (sequence stream &key (start 0) end) - (if (old-streamp stream) - (funcall *old-write-sequence* sequence stream :start start :end end) + (if (ansi-streamp stream) + (funcall *ansi-write-sequence* sequence stream :start start :end end) (stream-write-sequence stream sequence start end))) (defun gray-read-sequence (sequence stream &key (start 0) end) - (if (old-streamp stream) - (funcall *old-read-sequence* sequence stream :start start :end end) + (if (ansi-streamp stream) + (funcall *ansi-read-sequence* sequence stream :start start :end end) (stream-read-sequence stream sequence start end))) +(defgeneric stream-file-position (stream &optional position-spec)) + +(defun gray-file-position (stream &optional position-spec) + (if position-spec + (if (ansi-streamp stream) + (funcall *ansi-file-position* stream position-spec) + (stream-file-position stream position-spec)) + (if (ansi-streamp stream) + (funcall *ansi-file-position* stream) + (stream-file-position stream)))) + #| (defstruct (two-way-stream-g (:include stream)) input-stream output-stream) (defun gray-make-two-way-stream (in out) - (if (and (old-streamp in) (old-streamp out)) - (funcall *old-make-two-way-stream* in out) + (if (and (ansi-streamp in) (ansi-streamp out)) + (funcall *ansi-make-two-way-stream* in out) (make-two-way-stream-g :input-stream in :output-stream out))) (defun gray-two-way-stream-input-stream (stream) - (if (old-streamp stream) - (funcall *old-two-way-stream-input-stream* stream) + (if (ansi-streamp stream) + (funcall *ansi-two-way-stream-input-stream* stream) (two-way-stream-g-input-stream stream))) (defun gray-two-way-stream-output-stream (stream) - (if (old-streamp stream) - (funcall *old-two-way-stream-output-stream* stream) + (if (ansi-streamp stream) + (funcall *ansi-two-way-stream-output-stream* stream) (two-way-stream-g-output-stream stream))) |# @@ -592,6 +629,7 @@ (setf (symbol-function 'common-lisp::streamp) #'gray-streamp) (setf (symbol-function 'common-lisp::read-sequence) #'gray-read-sequence) (setf (symbol-function 'common-lisp::write-sequence) #'gray-write-sequence) +(setf (symbol-function 'common-lisp::file-position) #'gray-file-position) #| (setf (symbol-function 'common-lisp::make-two-way-stream) #'gray-make-two-way-stream) From mevenson at common-lisp.net Mon Mar 21 06:25:00 2011 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 21 Mar 2011 02:25:00 -0400 Subject: [armedbear-cvs] r13256 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Mar 21 02:24:58 2011 New Revision: 13256 Log: The sharpsign backslash macro now understands \unnnn as an escape for a Unicode chararcter. Modified: trunk/abcl/src/org/armedbear/lisp/LispCharacter.java Modified: trunk/abcl/src/org/armedbear/lisp/LispCharacter.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispCharacter.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispCharacter.java Mon Mar 21 02:24:58 2011 @@ -553,6 +553,14 @@ String lower = s.toLowerCase(); LispCharacter lc = namedToChar.get(lower); if (lc!=null) return lc.value; + if (lower.length() == 5 + && lower.startsWith("u")) { + try { + int i = Integer.parseInt(lower.substring(1, 5), 16); + return i; + } catch (NumberFormatException e) {}; + } + if (lower.equals("null")) return 0; if (lower.equals("bell")) @@ -617,7 +625,12 @@ case 127: return "Rubout"; } - if (c<0 || c>255) return null; + + if (c > 255) { + return "U" + Integer.toString(c, 16); + } + + if (c<0) return null; return lispChars.get(c).name; } From mevenson at common-lisp.net Sun Mar 27 10:50:57 2011 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 27 Mar 2011 06:50:57 -0400 Subject: [armedbear-cvs] r13257 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun Mar 27 06:50:56 2011 New Revision: 13257 Log: Fix compilation of LOGAND for args that could possibly be nil. Fixes ticket #142. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Mar 27 06:50:56 2011 @@ -4408,9 +4408,9 @@ (emit 'iand) (convert-representation :int representation) (emit-move-from-stack target representation)) - ((or (and (fixnum-type-p type1) + ((or (and (fixnum-type-p type1) (member type2 '(:long :int)) (compiler-subtypep type1 'unsigned-byte)) - (and (fixnum-type-p type2) + (and (fixnum-type-p type2) (member type1 '(:long :int)) (compiler-subtypep type2 'unsigned-byte))) ;; One of the arguments is a positive fixnum. (with-operand-accumulation @@ -4429,9 +4429,9 @@ (emit 'land) (convert-representation :long representation) (emit-move-from-stack target representation)) - ((or (and (java-long-type-p type1) + ((or (and (java-long-type-p type1) (member type2 '(:long :int)) (compiler-subtypep type1 'unsigned-byte)) - (and (java-long-type-p type2) + (and (java-long-type-p type2) (member type1 '(:long :int)) (compiler-subtypep type2 'unsigned-byte))) ;; One of the arguments is a positive long. (with-operand-accumulation From mevenson at common-lisp.net Mon Mar 28 14:47:47 2011 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 28 Mar 2011 10:47:47 -0400 Subject: [armedbear-cvs] r13258 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Mar 28 10:47:46 2011 New Revision: 13258 Log: Update to ASDF-2.014. Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Mon Mar 28 10:47:46 2011 @@ -1,5 +1,5 @@ ;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.013: Another System Definition Facility. +;;; This is ASDF 2.014: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . @@ -68,6 +68,22 @@ (in-package :asdf) +;;; Strip out formating that is not supported on Genera. +(defmacro compatfmt (format) + #-genera format + #+genera + (let ((r '(("~@<" . "") + ("; ~@;" . "; ") + ("~3i~_" . "") + ("~@:>" . "") + ("~:>" . "")))) + (dolist (i r) + (loop :for found = (search (car i) format) :while found :do + (setf format (concatenate 'simple-string (subseq format 0 found) + (cdr i) + (subseq format (+ found (length (car i)))))))) + format)) + ;;;; Create packages in a way that is compatible with hot-upgrade. ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 ;;;; See more near the end of the file. @@ -83,18 +99,18 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.013") + (asdf-version "2.014") (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* - "~&; Upgrading ASDF package ~@[from version ~A ~]to version ~A~%" - existing-version asdf-version)) + (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") + existing-version asdf-version)) (labels ((present-symbol-p (symbol package) - (member (nth-value 1 (find-symbol symbol package)) '(:internal :external))) + (member (nth-value 1 (find-sym symbol package)) '(:internal :external))) (present-symbols (package) ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera (let (l) @@ -422,7 +438,7 @@ (defun* normalize-pathname-directory-component (directory) (cond - #-(or sbcl cmu) + #-(or cmu sbcl scl) ((stringp directory) `(:absolute ,directory) directory) #+gcl ((and (consp directory) (stringp (first directory))) @@ -431,7 +447,7 @@ (and (consp directory) (member (first directory) '(:absolute :relative)))) directory) (t - (error "Unrecognized pathname directory component ~S" directory)))) + (error (compatfmt "~@") directory)))) (defun* merge-pathname-directory-components (specified defaults) (let ((directory (normalize-pathname-directory-component specified))) @@ -461,6 +477,9 @@ Also, if either argument is NIL, then the other argument is returned unmodified." (when (null specified) (return-from merge-pathnames* defaults)) (when (null defaults) (return-from merge-pathnames* specified)) + #+scl + (ext:resolve-pathname specified defaults) + #-scl (let* ((specified (pathname specified)) (defaults (pathname defaults)) (directory (normalize-pathname-directory-component (pathname-directory specified))) @@ -509,15 +528,10 @@ (defun* last-char (s) (and (stringp s) (plusp (length s)) (char s (1- (length s))))) -(defun* errfmt (out format-string &rest format-args) - (declare (dynamic-extent format-args)) - (apply #'format out - #-genera (format nil "~~@<~A~~:>" format-string) #+genera format-string - format-args)) - + (defun* asdf-message (format-string &rest format-args) (declare (dynamic-extent format-args)) - (apply #'errfmt *verbose-out* format-string format-args)) + (apply #'format *verbose-out* format-string format-args)) (defun* split-string (string &key max (separator '(#\Space #\Tab))) "Split STRING into a list of components separated by @@ -569,7 +583,7 @@ pathnames." (check-type s string) (when (find #\: s) - (error "a portable ASDF pathname designator cannot include a #\: character: ~S" s)) + (error (compatfmt "~@") s)) (let* ((components (split-string s :separator "/")) (last-comp (car (last components)))) (multiple-value-bind (relative components) @@ -577,7 +591,7 @@ (if (equal (first-char s) #\/) (progn (when force-relative - (error "absolute pathname designator not allowed: ~S" s)) + (error (compatfmt "~@") s)) (values :absolute (cdr components))) (values :relative nil)) (values :relative components)) @@ -648,9 +662,9 @@ ((stringp pathspec) (ensure-directory-pathname (pathname pathspec))) ((not (pathnamep pathspec)) - (error "Invalid pathname designator ~S" pathspec)) + (error (compatfmt "~@") pathspec)) ((wild-pathname-p pathspec) - (error "Can't reliably convert wild pathname ~S" pathspec)) + (error (compatfmt "~@") pathspec)) ((directory-pathname-p pathspec) pathspec) (t @@ -716,10 +730,10 @@ (error () (error "Unable to find out user ID"))))))) (defun* pathname-root (pathname) - (make-pathname :host (pathname-host pathname) - :device (pathname-device pathname) - :directory '(:absolute) - :name nil :type nil :version nil)) + (make-pathname :directory '(:absolute) + :name nil :type nil :version nil + :defaults pathname ;; host device, and on scl scheme scheme-specific-part port username password + . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) (defun* find-symbol* (s p) (find-symbol (string s) p)) @@ -744,7 +758,7 @@ (when (typep p 'logical-pathname) (return p)) (let ((found (probe-file* p))) (when found (return found))) - #-(or sbcl cmu) (when (stringp directory) (return p)) + #-(or cmu sbcl scl) (when (stringp directory) (return p)) (when (not (eq :absolute (car directory))) (return p)) (let ((sofar (probe-file* (pathname-root p)))) (unless sofar (return p)) @@ -792,10 +806,12 @@ (defun* wilden (path) (merge-pathnames* *wild-path* path)) +#-scl (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname))) (last-char (namestring foo)))) +#-scl (defun* directorize-pathname-host-device (pathname) (let* ((root (pathname-root pathname)) (wild-root (wilden root)) @@ -815,6 +831,31 @@ :directory `(:absolute , at path)))) (translate-pathname absolute-pathname wild-root (wilden new-base)))))) +#+scl +(defun* directorize-pathname-host-device (pathname) + (let ((scheme (ext:pathname-scheme pathname)) + (host (pathname-host pathname)) + (port (ext:pathname-port pathname)) + (directory (pathname-directory pathname))) + (flet ((not-unspecific (component) + (and (not (eq component :unspecific)) component))) + (cond ((or (not-unspecific port) + (and (not-unspecific host) (plusp (length host))) + (not-unspecific scheme)) + (let ((prefix "")) + (when (not-unspecific port) + (setf prefix (format nil ":~D" port))) + (when (and (not-unspecific host) (plusp (length host))) + (setf prefix (concatenate 'string host prefix))) + (setf prefix (concatenate 'string ":" prefix)) + (when (not-unspecific scheme) + (setf prefix (concatenate 'string scheme prefix))) + (assert (and directory (eq (first directory) :absolute))) + (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) + :defaults pathname))) + (t + pathname))))) + ;;;; ------------------------------------------------------------------------- ;;;; ASDF Interface, in terms of generic functions. (defgeneric* find-system (system &optional error-p)) @@ -930,7 +971,8 @@ ((m module) added deleted plist &key) (declare (ignorable deleted plist)) (when (or *asdf-verbose* *load-verbose*) - (asdf-message "~&; Updating ~A for ASDF ~A~%" m ,(asdf-version))) + (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%") + m ,(asdf-version))) (when (member 'components-by-name added) (compute-module-components-by-name m)) (when (typep m 'system) @@ -969,25 +1011,26 @@ ((format-control :initarg :format-control :reader format-control) (format-arguments :initarg :format-arguments :reader format-arguments)) (:report (lambda (c s) - (apply #'errfmt s (format-control c) (format-arguments c))))) + (apply #'format s (format-control c) (format-arguments c))))) (define-condition load-system-definition-error (system-definition-error) ((name :initarg :name :reader error-name) (pathname :initarg :pathname :reader error-pathname) (condition :initarg :condition :reader error-condition)) (:report (lambda (c s) - (errfmt s "Error while trying to load definition for system ~A from pathname ~A: ~A" + (format s (compatfmt "~@") (error-name c) (error-pathname c) (error-condition c))))) (define-condition circular-dependency (system-definition-error) ((components :initarg :components :reader circular-dependency-components)) (:report (lambda (c s) - (errfmt s "Circular dependency: ~S" (circular-dependency-components c))))) + (format s (compatfmt "~@") + (circular-dependency-components c))))) (define-condition duplicate-names (system-definition-error) ((name :initarg :name :reader duplicate-names-name)) (:report (lambda (c s) - (errfmt s "Error while defining system: multiple components are given same name ~A" + (format s (compatfmt "~@") (duplicate-names-name c))))) (define-condition missing-component (system-definition-error) @@ -1008,7 +1051,7 @@ ((component :reader error-component :initarg :component) (operation :reader error-operation :initarg :operation)) (:report (lambda (c s) - (errfmt s "erred while invoking ~A on ~A" + (format s (compatfmt "~@") (error-operation c) (error-component c))))) (define-condition compile-error (operation-error) ()) (define-condition compile-failed (compile-error) ()) @@ -1020,14 +1063,14 @@ (format :reader condition-format :initarg :format) (arguments :reader condition-arguments :initarg :arguments :initform nil)) (:report (lambda (c s) - (errfmt s "~? (will be skipped)" + (format s (compatfmt "~@<~? (will be skipped)~@:>") (condition-format c) (list* (condition-form c) (condition-location c) (condition-arguments c)))))) (define-condition invalid-source-registry (invalid-configuration warning) - ((format :initform "invalid source registry ~S~@[ in ~S~]~@{ ~@?~}"))) + ((format :initform (compatfmt "~@")))) (define-condition invalid-output-translation (invalid-configuration warning) - ((format :initform "invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}"))) + ((format :initform (compatfmt "~@")))) (defclass component () ((name :accessor component-name :initarg :name :documentation @@ -1091,7 +1134,7 @@ ;;;; methods: conditions (defmethod print-object ((c missing-dependency) s) - (format s "~A, required by ~A" + (format s (compatfmt "~@<~A, required by ~A~@:>") (call-next-method c nil) (missing-required-by c))) (defun* sysdef-error (format &rest arguments) @@ -1101,13 +1144,13 @@ ;;;; methods: components (defmethod print-object ((c missing-component) s) - (format s "component ~S not found~@[ in ~A~]" + (format s (compatfmt "~@") (missing-requires c) (when (missing-parent c) (coerce-name (missing-parent c))))) (defmethod print-object ((c missing-component-of-version) s) - (format s "component ~S does not match version ~A~@[ in ~A~]" + (format s (compatfmt "~@") (missing-requires c) (missing-version c) (when (missing-parent c) @@ -1167,7 +1210,7 @@ (component-relative-pathname component) (pathname-directory-pathname (component-parent-pathname component))))) (unless (or (null pathname) (absolute-pathname-p pathname)) - (error "Invalid relative pathname ~S for component ~S" + (error (compatfmt "~@") pathname (component-find-path component))) (setf (slot-value component 'absolute-pathname) pathname) pathname))) @@ -1236,7 +1279,7 @@ (component (component-name name)) (symbol (string-downcase (symbol-name name))) (string name) - (t (sysdef-error "invalid component designator ~A" name)))) + (t (sysdef-error (compatfmt "~@") name)))) (defun* system-registered-p (name) (gethash (coerce-name name) *defined-systems*)) @@ -1329,8 +1372,8 @@ (restart-case (let* ((*print-circle* nil) (message - (errfmt nil - "While searching for system ~S: ~S evaluated to ~S which is not a directory." + (format nil + (compatfmt "~@") system dir defaults))) (error message)) (remove-entry-from-registry () @@ -1338,7 +1381,7 @@ (push dir to-remove)) (coerce-entry-to-directory () :report (lambda (s) - (errfmt s "Coerce entry to ~a, replace ~a and continue." + (format s (compatfmt "~@") (ensure-directory-pathname defaults) dir)) (push (cons dir (ensure-directory-pathname defaults)) to-replace)))))))) ;; cleanup @@ -1374,7 +1417,7 @@ (or (and pathname (probe-file* pathname) (file-write-date pathname)) (progn (when (and pathname *asdf-verbose*) - (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero." + (warn (compatfmt "~@") pathname)) 0))) @@ -1391,9 +1434,8 @@ :name name :pathname pathname :condition condition)))) (let ((*package* package)) - (asdf-message - "~&; Loading system definition from ~A into ~A~%" - pathname package) + (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") + pathname package) (load pathname))) (delete-package package)))) @@ -1418,9 +1460,10 @@ (error 'missing-component :requires name))))))) (defun* register-system (name system) - (asdf-message "~&; Registering ~A as ~A~%" system name) - (setf (gethash (coerce-name name) *defined-systems*) - (cons (get-universal-time) system))) + (setf name (coerce-name name)) + (assert (equal name (component-name system))) + (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) + (setf (gethash name *defined-systems*) (cons (get-universal-time) system))) (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) (setf fallback (coerce-name fallback) @@ -1496,11 +1539,6 @@ (declare (ignorable s)) (source-file-explicit-type component)) -(defun* merge-component-name-type (name &key type defaults) - ;; For backwards compatibility only, for people using internals. - ;; Will be removed in a future release, e.g. 2.014. - (coerce-pathname name :type type :defaults defaults)) - (defun* coerce-pathname (name &key type defaults) "coerce NAME into a PATHNAME. When given a string, portably decompose it into a relative pathname: @@ -1515,9 +1553,8 @@ ;; to the below make-pathname, which may crucially matter to people using ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames. ;; NOTE that the host and device slots will be taken from the defaults, - ;; but that should only matter if you either (a) use absolute pathnames, or - ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of - ;; ASDF:MERGE-PATHNAMES* + ;; but that should only matter if you later merge relative pathnames with + ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES* (etypecase name ((or null pathname) name) @@ -1535,12 +1572,13 @@ (values filename type)) (t (split-name-type filename))) - (let* ((defaults (pathname (or defaults *default-pathname-defaults*))) - (host (pathname-host defaults)) - (device (pathname-device defaults))) - (make-pathname :directory `(,relative , at path) - :name name :type type - :host host :device device))))))) + (make-pathname :directory `(,relative , at path) :name name :type type + :defaults (or defaults *default-pathname-defaults*))))))) + +(defun* merge-component-name-type (name &key type defaults) + ;; For backwards compatibility only, for people using internals. + ;; Will be removed in a future release, e.g. 2.014. + (coerce-pathname name :type type :defaults defaults)) (defmethod component-relative-pathname ((component component)) (coerce-pathname @@ -1764,7 +1802,7 @@ required-op required-c required-v)) (retry () :report (lambda (s) - (errfmt s "Retry loading component ~S." required-c)) + (format s "~@" required-c)) :test (lambda (c) (or (null c) @@ -1808,7 +1846,7 @@ (when (find (second d) *features* :test 'string-equal) (dep op (third d) nil))) (t - (error "Bad dependency ~a. Dependencies must be (:version ), (:feature [version]), or a name" d)))))) + (error (compatfmt "~@), (:feature [version]), or a name.~@:>") d)))))) flag)))) (defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes @@ -1933,7 +1971,7 @@ (defmethod perform ((operation operation) (c source-file)) (sysdef-error - "required method PERFORM not implemented for operation ~A, component ~A" + (compatfmt "~@") (class-of operation) (class-of c))) (defmethod perform ((operation operation) (c module)) @@ -1944,7 +1982,8 @@ (asdf-message "~&;;; ~A~%" (operation-description operation component))) (defmethod operation-description (operation component) - (format nil "~A on component ~S" (class-of operation) (component-find-path component))) + (format nil (compatfmt "~@<~A on component ~S~@:>") + (class-of operation) (component-find-path component))) ;;;; ------------------------------------------------------------------------- ;;;; compile-op @@ -1994,14 +2033,14 @@ (when warnings-p (case (operation-on-warnings operation) (:warn (warn - "COMPILE-FILE warned while performing ~A on ~A." + (compatfmt "~@") operation c)) (:error (error 'compile-warned :component c :operation operation)) (:ignore nil))) (when failure-p (case (operation-on-failure operation) (:warn (warn - "COMPILE-FILE failed while performing ~A on ~A." + (compatfmt "~@") operation c)) (:error (error 'compile-failed :component c :operation operation)) (:ignore nil))) @@ -2103,7 +2142,8 @@ (defmethod operation-description ((operation load-op) component) (declare (ignorable operation)) - (format nil "loading component ~S" (component-find-path component))) + (format nil (compatfmt "~@") + (component-find-path component))) ;;;; ------------------------------------------------------------------------- @@ -2146,7 +2186,8 @@ (defmethod operation-description ((operation load-source-op) component) (declare (ignorable operation)) - (format nil "loading component ~S" (component-find-path component))) + (format nil (compatfmt "~@") + (component-find-path component))) ;;;; ------------------------------------------------------------------------- @@ -2197,11 +2238,12 @@ (retry () :report (lambda (s) - (errfmt s "Retry ~A." (operation-description op component)))) + (format s (compatfmt "~@") + (operation-description op component)))) (accept () :report (lambda (s) - (errfmt s "Continue, treating ~A as having been successful." + (format s (compatfmt "~@") (operation-description op component))) (setf (gethash (type-of op) (component-operation-times component)) @@ -2287,6 +2329,7 @@ (default-directory)))) (defmacro defsystem (name &body options) + (setf name (coerce-name name)) (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system) defsystem-depends-on &allow-other-keys) options @@ -2296,7 +2339,7 @@ ;; we recur when trying to find an existing system of the same name ;; to reuse options (e.g. pathname) from ,@(loop :for system :in defsystem-depends-on - :collect `(load-system ,system)) + :collect `(load-system ',(coerce-name system))) (let ((s (system-registered-p ',name))) (cond ((and s (eq (type-of (cdr s)) ',class)) (setf (car s) (get-universal-time))) @@ -2357,7 +2400,7 @@ (defun* sysdef-error-component (msg type name value) (sysdef-error (concatenate 'string msg - "~&The value specified for ~(~A~) ~A is ~S") + (compatfmt "~&~@")) type name value)) (defun* check-component-input (type name weakly-depends-on @@ -2688,13 +2731,13 @@ (t (apply #'warn fstring args) "unknown")))) (let ((lisp (maybe-warn (implementation-type) - "No implementation feature found in ~a." + (compatfmt "~@") *implementation-features*)) (os (maybe-warn (first-feature *os-features*) - "No os feature found in ~a." *os-features*)) + (compatfmt "~@") *os-features*)) (arch (or #-clisp (maybe-warn (first-feature *architecture-features*) - "No architecture feature found in ~a." + (compatfmt "~@") *architecture-features*))) (version (maybe-warn (lisp-version-string) "Don't know how to get Lisp implementation version."))) @@ -2794,14 +2837,15 @@ :finally (unless (= inherit 1) (report-invalid-form invalid-form-reporter - :arguments (list "One and only one of ~S or ~S is required" + :arguments (list (compatfmt "~@") :inherit-configuration :ignore-inherited-configuration))) (return (nreverse x)))) (defun* validate-configuration-file (file validator &key description) (let ((forms (read-file-forms file))) (unless (length=n-p forms 1) - (error "One and only one form allowed for ~A. Got: ~S~%" description forms)) + (error (compatfmt "~@~%") + description forms)) (funcall validator (car forms) :location file))) (defun* hidden-file-p (pathname) @@ -2922,7 +2966,7 @@ (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r))) (s (if (or (pathnamep x) (not wilden)) d (wilden d)))) (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super)))) - (error "pathname ~S is not relative to ~S" s super)) + (error (compatfmt "~@") s super)) (merge-pathnames* s super))) (defvar *here-directory* nil @@ -2964,7 +3008,7 @@ (wilden r) r))) (unless (absolute-pathname-p s) - (error "Not an absolute pathname ~S" s)) + (error (compatfmt "~@") s)) s)) (defun* resolve-location (x &key directory wilden) @@ -3036,7 +3080,7 @@ ((or (null string) (equal string "")) '(:output-translations :inherit-configuration)) ((not (stringp string)) - (error "environment string isn't: ~S" string)) + (error (compatfmt "~@") string)) ((eql (char string 0) #\") (parse-output-translations-string (read-from-string string) :location location)) ((eql (char string 0) #\() @@ -3056,7 +3100,8 @@ (setf source nil)) ((equal "" s) (when inherit - (error "only one inherited configuration allowed: ~S" string)) + (error (compatfmt "~@") + string)) (setf inherit t) (push :inherit-configuration directives)) (t @@ -3064,7 +3109,8 @@ (setf start (1+ i)) (when (> start end) (when source - (error "Uneven number of components in source to destination mapping ~S" string)) + (error (compatfmt "~@") + string)) (unless inherit (push :ignore-inherited-configuration directives)) (return `(:output-translations ,@(nreverse directives))))))))) @@ -3215,7 +3261,7 @@ ((eq destination t) path) ((not (pathnamep destination)) - (error "invalid destination")) + (error "Invalid destination")) ((not (absolute-pathname-p destination)) (translate-pathname path absolute-source (merge-pathnames* destination root))) (root @@ -3546,7 +3592,7 @@ ((or (null string) (equal string "")) '(:source-registry :inherit-configuration)) ((not (stringp string)) - (error "environment string isn't: ~S" string)) + (error (compatfmt "~@") string)) ((find (char string 0) "\"(") (validate-source-registry-form (read-from-string string) :location location)) (t @@ -3560,7 +3606,8 @@ (cond ((equal "" s) ; empty element: inherit (when inherit - (error "only one inherited configuration allowed: ~S" string)) + (error (compatfmt "~@") + string)) (setf inherit t) (push ':inherit-configuration directives)) ((ends-with s "//") @@ -3756,13 +3803,12 @@ ((style-warning #'muffle-warning) (missing-component (constantly nil)) (error #'(lambda (e) - (errfmt *error-output* "ASDF could not load ~(~A~) because ~A.~%" + (format *error-output* (compatfmt "~@~%") name e)))) - (let* ((*verbose-out* (make-broadcast-stream)) + (let ((*verbose-out* (make-broadcast-stream)) (system (find-system (string-downcase name) nil))) (when system - (load-system system) - t)))) + (load-system system))))) #+(or abcl clisp clozure cmu ecl sbcl) (let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom))))