From ehuelsmann at common-lisp.net Sat Sep 1 20:59:41 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 01 Sep 2012 13:59:41 -0700 Subject: [armedbear-cvs] r14142 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Sep 1 13:59:40 2012 New Revision: 14142 Log: Fix the incremental build. Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Fri Aug 31 16:29:06 2012 (r14141) +++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Sat Sep 1 13:59:40 2012 (r14142) @@ -257,13 +257,13 @@ (*prevent-fasl-circle-detection* t)) (unless output-path (setf output-path *default-pathname-defaults*)) - (flet ((do-compile (file) + (flet ((do-compile (file &key (extract t)) (let ((out (make-pathname :type *compile-file-type* :defaults (merge-pathnames file output-path)))) (compile-file-if-needed file :output-file out - :extract-toplevel-funcs-and-macros t)))) + :extract-toplevel-funcs-and-macros extract)))) (load (do-compile "defstruct.lisp")) (load (do-compile "coerce.lisp")) (load (do-compile "open.lisp")) @@ -452,8 +452,10 @@ (generate-autoloads output-path) ;; Compile the file in the build directory instead of the one in the ;; sources directory - the latter being for bootstrapping only. - (do-compile (merge-pathnames #p"autoloads-gen.lisp" output-path)) - (do-compile "autoloads.lisp")) + (do-compile (merge-pathnames #p"autoloads-gen.lisp" output-path) + :extract nil) + (do-compile "autoloads.lisp" + :extract nil)) t)) (defun compile-system (&key quit (zip t) (cls-ext *compile-file-class-extension*) (abcl-ext *compile-file-type*) output-path) From ehuelsmann at common-lisp.net Sat Sep 1 21:00:51 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 01 Sep 2012 14:00:51 -0700 Subject: [armedbear-cvs] r14143 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: ehuelsmann Date: Sat Sep 1 14:00:49 2012 New Revision: 14143 Log: Close #189: Fix thinko in MIN and MAX return value type derivation. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/test/lisp/abcl/compiler-tests.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Sep 1 13:59:40 2012 (r14142) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Sep 1 14:00:49 2012 (r14143) @@ -5247,7 +5247,8 @@ (define-int-bounds-derivation max (low1 low2 high1 high2) (values (or (when (and low1 low2) (max low1 low2)) low1 low2) - (or (when (and high1 high2) (max high1 high2)) high1 high2))) + ; if either maximum is unbound, their maximum is unbound + (when (and high1 high2) (max high1 high2)))) (declaim (ftype (function (t) t) derive-type-max)) (defun derive-type-max (form) @@ -5256,7 +5257,8 @@ (derive-compiler-types args op))) (define-int-bounds-derivation min (low1 high1 low2 high2) - (values (or (when (and low1 low2) (min low1 low2)) low1 low2) + (values (when (and low1 low2) (min low1 low2)) + ; if either minimum is unbound, their minimum is unbound (or (when (and high1 high2) (min high1 high2)) high1 high2))) (defknown derive-type-min (t) t) Modified: trunk/abcl/test/lisp/abcl/compiler-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/compiler-tests.lisp Sat Sep 1 13:59:40 2012 (r14142) +++ trunk/abcl/test/lisp/abcl/compiler-tests.lisp Sat Sep 1 14:00:49 2012 (r14143) @@ -473,10 +473,12 @@ t) +;;; ticket #189 +(deftest compiler.3 + (eql (funcall (compile nil (lambda (a) + (declare (type unsigned-byte a)) + (max 28105919 a 1016934843))) + 10545160975) + 10545160975) + t) - - - - - - \ No newline at end of file From ehuelsmann at common-lisp.net Sat Sep 1 21:03:06 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 01 Sep 2012 14:03:06 -0700 Subject: [armedbear-cvs] r14144 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Sep 1 14:03:05 2012 New Revision: 14144 Log: The OPCODES file doesn't exist anymore and has been merged into jvm-instructions.lisp. However, shouldn't we just eliminate this file instead?? Modified: trunk/abcl/src/org/armedbear/lisp/dump-class.lisp Modified: trunk/abcl/src/org/armedbear/lisp/dump-class.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/dump-class.lisp Sat Sep 1 14:00:49 2012 (r14143) +++ trunk/abcl/src/org/armedbear/lisp/dump-class.lisp Sat Sep 1 14:03:05 2012 (r14144) @@ -29,7 +29,7 @@ ;;; obligated to do so. If you do not wish to do so, delete this ;;; exception statement from your version. -(require '#:opcodes) +(require '#:jvm-instructions) (in-package #:jvm) @@ -55,7 +55,7 @@ ((7 8) (list tag (read-u2 stream))) (1 - (let* ((len (read-u2 stream)) +` (let* ((len (read-u2 stream)) (s (make-string len))) (dotimes (i len) (setf (char s i) (code-char (read-u1 stream)))) From ehuelsmann at common-lisp.net Sat Sep 1 21:44:37 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 01 Sep 2012 14:44:37 -0700 Subject: [armedbear-cvs] r14145 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Sep 1 14:44:36 2012 New Revision: 14145 Log: Re #225: Can't reproduce and can't find the exact cause anymore. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Sep 1 14:03:05 2012 (r14144) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Sep 1 14:44:36 2012 (r14145) @@ -2255,8 +2255,6 @@ (let* ((method (%car (sys:%generic-function-methods gf))) (specializer (car (std-method-specializers method))) (function (std-method-fast-function method))) - ;;### The above doesn't work: STD-METHOD-FUNCTION - ;; is a function of 2 args: ARGS and NEXT-EMFUN and being called with one below... (if (typep specializer 'eql-specializer) (let ((specializer-object (eql-specializer-object specializer))) #'(lambda (arg) From ehuelsmann at common-lisp.net Sat Sep 1 21:45:34 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 01 Sep 2012 14:45:34 -0700 Subject: [armedbear-cvs] r14146 - trunk/abcl/test/lisp/abcl Message-ID: Author: ehuelsmann Date: Sat Sep 1 14:45:33 2012 New Revision: 14146 Log: Re #241: Add test cases. Modified: trunk/abcl/test/lisp/abcl/compiler-tests.lisp Modified: trunk/abcl/test/lisp/abcl/compiler-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/compiler-tests.lisp Sat Sep 1 14:44:36 2012 (r14145) +++ trunk/abcl/test/lisp/abcl/compiler-tests.lisp Sat Sep 1 14:45:33 2012 (r14146) @@ -482,3 +482,20 @@ 10545160975) t) + +;;; ticket #241 +(deftest compiler.4a + (multiple-value-bind + (rv error) + (ignore-errors + (compile nil '(lambda (&rest args &optional x)))) + (typep error 'program-error)) + t) + +(deftest compiler.4b + (multiple-value-bind + (rv error) + (ignore-errors + (compile nil '(lambda (&key args &optional x)))) + (typep error 'program-error)) + t) \ No newline at end of file From ehuelsmann at common-lisp.net Sun Sep 2 11:38:32 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 02 Sep 2012 04:38:32 -0700 Subject: [armedbear-cvs] r14147 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Sep 2 04:38:30 2012 New Revision: 14147 Log: Close #241: Fix "part 2": ABCL accepts disallowed lambda list ordering. Note: Solved by rewriting PARSE-LAMBDA-LIST. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sat Sep 1 14:45:33 2012 (r14146) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Sep 2 04:38:30 2012 (r14147) @@ -94,6 +94,7 @@ " (let ((remaining lambda-list) (state :req) + keyword-required req opt key rest whole env aux key-p allow-others-p) (when (eq (car lambda-list) '&WHOLE) (let ((var (second lambda-list))) @@ -104,59 +105,99 @@ :format-arguments (list var lambda-list))) (setf whole (list var)) (setf remaining (nthcdr 2 lambda-list)))) - (dolist (arg remaining) - (case arg - (&optional (setf state :opt)) - (&key (setf state :key - key-p t)) - (&rest (setf state :rest)) - (&aux (setf state :aux)) - (&allow-other-keys (setf state :none - allow-others-p t)) - (&whole (setf state :whole)) - (&environment (setf state :env)) - (&whole - (error 'program-error - :format-control "&WHOLE must appear first in lambda list ~A." - :format-arguments (list lambda-list))) - (t - (case state - (:req (push (list arg) req)) - (:rest (setf rest (list arg) - state :none)) - (:env (setf env (list arg) - state :req)) - (:none - (error "Invalid lambda list: argument found in :none state.")) - (:opt - (cond - ((symbolp arg) - (push (list arg nil nil nil) opt)) - ((consp arg) - (push (list (car arg) (cadr arg) (caddr arg)) opt)) - (t - (error "Invalid state.")))) - (:aux - (cond - ((symbolp arg) - (push (list arg nil nil nil) aux)) - ((consp arg) - (push (list (car arg) (cadr arg) nil nil) aux)) - (t - (error "Invalid :aux state.")))) - (:key - (cond - ((symbolp arg) - (push (list arg nil nil (sys::keywordify arg)) key)) - ((and (consp arg) - (consp (car arg))) - (push (list (cadar arg) (cadr arg) (caddr arg) (caar arg)) key)) - ((consp arg) - (push (list (car arg) (cadr arg) (caddr arg) - (sys::keywordify (car arg))) key)) - (t - (error "Invalid :key state.")))) - (t (error "Invalid state found.")))))) + + (do* ((arg (pop remaining) (pop tail)) + (tail remaining tail)) + ((and (null arg) + (endp tail))) + (let* ((allowable-previous-states + ;; even if the arglist could theoretically contain the + ;; keyword :req, this still works, because the cdr will + ;; be NIL, meaning that the code below thinks we DIDN'T + ;; find a new state. Which happens to be true. + (cdr (member arg '(&whole &environment &aux &allow-other-keys + &key &rest &optional :req))))) + (cond + (allowable-previous-states + (setf keyword-required nil) ;; we have a keyword... + (case arg + (&key + (setf key-p t)) + (&rest + (when (endp tail) + (error 'program-error + :format-control "&REST without variable in lambda list ~A." + :format-arguments (list lambda-list))) + (setf rest (list (pop tail)) + keyword-required t)) + (&allow-other-keys + (unless (eq state '&KEY) + (error 'program-error + :format-control "&ALLOW-OTHER-KEYS outside of &KEY ~ + section in lambda list ~A" + :format-arguments (list lambda-list))) + (setf allow-others-p t + keyword-required t + arg nil)) + (&environment + (setf env (list (pop tail)) + keyword-required t + ;; &ENVIRONMENT can appear anywhere; retain our last + ;; state so we know what next keywords are valid + arg state)) + (&whole + (error 'program-error + :format-control "&WHOLE must appear first in lambda list ~A." + :format-arguments (list lambda-list)))) + (when arg + ;; ### verify that the next state is valid + (unless (or (null state) + (member state allowable-previous-states)) + (error 'program-error + :format-control "~A not allowed after ~A ~ + in lambda-list ~S" + :format-arguments (list arg state lambda-list))) + (setf state arg))) + (keyword-required + ;; a keyword was required, but none was found... + (error 'program-error + :format-control "Lambda list keyword expected, but found ~ + ~A in lambda list ~A" + :format-arguments (list arg lambda-list))) + (t ;; a variable specification + (case state + (:req (push (list arg) req)) + (&optional + (cond ((symbolp arg) + (push (list arg) opt)) + ((consp arg) + (push (list (car arg) (cadr arg) + (caddr arg)) opt)) + (t + (error "Invalid &OPTIONAL variable.")))) + (&key + (cond ((symbolp arg) + (push (list arg nil nil (sys::keywordify arg)) key)) + ((consp arg) + (push (list (if (consp (car arg)) + (cadar arg) (car arg)) + (cadr arg) (caddr arg) + (if (consp (car arg)) + (caar arg) + (sys::keywordify (car arg)))) key)) + (t + (error "Invalid &KEY variable.")))) + (&aux + (cond ((symbolp arg) + (push (list arg nil nil nil) aux)) + ((consp arg) + (push (list (car arg) (cadr arg) nil nil) aux)) + (t + (error "Invalid &aux state.")))) + (t + (error 'program-error + :format-control "Invalid state found: ~A." + :format-arguments (list state)))))))) (values (nreverse req) (nreverse opt) From ehuelsmann at common-lisp.net Sun Sep 2 18:11:32 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 02 Sep 2012 11:11:32 -0700 Subject: [armedbear-cvs] r14148 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Sep 2 11:11:30 2012 New Revision: 14148 Log: Fix #130: SLIME has extra ^M character in buffer output on Windows. Note: Verified this symptom still exists in August Quicklisp; Solution on our side is probably easiest. Modified: trunk/abcl/src/org/armedbear/lisp/SlimeInputStream.java trunk/abcl/src/org/armedbear/lisp/SlimeOutputStream.java Modified: trunk/abcl/src/org/armedbear/lisp/SlimeInputStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlimeInputStream.java Sun Sep 2 04:38:30 2012 (r14147) +++ trunk/abcl/src/org/armedbear/lisp/SlimeInputStream.java Sun Sep 2 11:11:30 2012 (r14148) @@ -50,6 +50,7 @@ isOutputStream = false; isCharacterStream = true; isBinaryStream = false; + eolStyle = EolStyle.LF; this.f = f; this.ostream = ostream; } Modified: trunk/abcl/src/org/armedbear/lisp/SlimeOutputStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlimeOutputStream.java Sun Sep 2 04:38:30 2012 (r14147) +++ trunk/abcl/src/org/armedbear/lisp/SlimeOutputStream.java Sun Sep 2 11:11:30 2012 (r14148) @@ -50,6 +50,7 @@ isOutputStream = true; isCharacterStream = true; isBinaryStream = false; + eolStyle = EolStyle.LF; setWriter(stringWriter = new StringWriter()); this.f = f; } From rschlatte at common-lisp.net Wed Sep 5 10:29:57 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 05 Sep 2012 03:29:57 -0700 Subject: [armedbear-cvs] r14149 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed Sep 5 03:29:55 2012 New Revision: 14149 Log: Fix subtypep for anonymous classes - Only use class name if the class has a proper name - The class name of an anonymous class is NIL, which is the universal subtype - Similarly, (setf (class-name c) t) would make c a supertype of everything ... - Reported by Pascal Costanza Modified: trunk/abcl/src/org/armedbear/lisp/subtypep.lisp Modified: trunk/abcl/src/org/armedbear/lisp/subtypep.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/subtypep.lisp Sun Sep 2 11:11:30 2012 (r14148) +++ trunk/abcl/src/org/armedbear/lisp/subtypep.lisp Wed Sep 5 03:29:55 2012 (r14149) @@ -477,16 +477,20 @@ (t (values nil nil)))) -(defun %subtypep (type1 type2) +(defun properly-named-class-p (thing environment) + (and (classp thing) (class-name thing) + (eq thing (find-class (class-name thing) nil environment)))) + +(defun %subtypep (type1 type2 &optional environment) (when (or (eq type1 type2) (null type1) (eq type2 t) - (and (classp type2) (eq (%class-name type2) t))) + (and (classp type2) (eq type2 (find-class t)))) (return-from %subtypep (values t t))) - (when (classp type1) - (setf type1 (%class-name type1))) - (when (classp type2) - (setf type2 (%class-name type2))) + (when (properly-named-class-p type1 environment) + (setf type1 (class-name type1))) + (when (properly-named-class-p type2 environment) + (setf type2 (class-name type2))) (let ((ct1 (ctype type1)) (ct2 (ctype type2))) (multiple-value-bind (subtype-p valid-p) @@ -505,8 +509,8 @@ (and (symbolp type2) (find-class type2 nil))))) (return-from %subtypep (values (subclassp class1 class2) t))) (when (or classp-1 classp-2) - (let ((t1 (if classp-1 (%class-name type1) type1)) - (t2 (if classp-2 (%class-name type2) type2))) + (let ((t1 (if classp-1 (class-name type1) type1)) + (t2 (if classp-2 (class-name type2) type2))) (return-from %subtypep (values (simple-subtypep t1 t2) t)))))) (setf type1 (normalize-type type1) type2 (normalize-type type2)) @@ -590,7 +594,7 @@ (cond ((memq t2 '(integer rational real number)) (values (sub-interval-p i1 i2) t)) ((or (eq t2 'bignum) - (and (classp t2) (eq (%class-name t2) 'bignum))) + (and (classp t2) (eq (class-name t2) 'bignum))) (values (or (sub-interval-p i1 (list '* (list most-negative-fixnum))) (sub-interval-p i1 (list (list most-positive-fixnum) '*))) @@ -628,7 +632,7 @@ (t (values (subtypep (car i1) (car i2)) t)))))) ((and (classp t1) - (eq (%class-name t1) 'array) + (eq (class-name t1) 'array) (eq t2 'array)) (values (equal i2 '(* *)) t)) ((and (memq t1 '(array simple-array)) (eq t2 'array)) @@ -738,7 +742,7 @@ (t (values nil t))))) ((classp t2) - (let ((class-name (%class-name t2))) + (let ((class-name (class-name t2))) (cond ((eq class-name t1) (values t t)) ((and (eq class-name 'array) @@ -776,5 +780,4 @@ (values nil nil))))) (defun subtypep (type1 type2 &optional environment) - (declare (ignore environment)) - (%subtypep type1 type2)) + (%subtypep type1 type2 environment)) From mevenson at common-lisp.net Sat Sep 8 08:14:06 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 08 Sep 2012 01:14:06 -0700 Subject: [armedbear-cvs] r14150 - in trunk/abcl: doc/asdf src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat Sep 8 01:14:05 2012 New Revision: 14150 Log: Upgrade to asdf-2.24. 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 Wed Sep 5 03:29:55 2012 (r14149) +++ trunk/abcl/doc/asdf/asdf.texinfo Sat Sep 8 01:14:05 2012 (r14150) @@ -220,12 +220,12 @@ As of the writing of this manual, the following implementations provide ASDF 2 this way: -abcl allegro ccl clisp cmucl ecl lispworks sbcl xcl. +abcl allegro ccl clisp cmucl ecl lispworks mkcl sbcl xcl. The following implementation doesn't provide it yet but will in a future release: scl. The following implementations are obsolete, not actively maintained, and most probably will never bundle it: -cormancl gcl genera mcl. +cormanlisp gcl genera mcl. If the implementation you are using doesn't provide ASDF 2, see @pxref{Loading ASDF,,Loading an otherwise installed ASDF} below. @@ -637,7 +637,7 @@ @end example On some implementations (namely recent versions of -ABCL, Clozure CL, CLISP, CMUCL, ECL, SBCL and SCL), +ABCL, Allegro CL, Clozure CL, CMUCL, ECL, GNU CLISP, LispWorks, MKCL, SBCL and XCL), ASDF hooks into the @code{CL:REQUIRE} facility and you can just use: @@ -2917,7 +2917,7 @@ etc. Note that there is no around-load hook. This is on purpose. -Some implementations such as ECL or GCL link object files, +Some implementations such as ECL, GCL or MKCL link object files, which allows for no such hook. Other implementations allow for concatenating FASL files, which doesn't allow for such a hook either. Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf.lisp Wed Sep 5 03:29:55 2012 (r14149) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Sat Sep 8 01:14:05 2012 (r14150) @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- -;;; This is ASDF 2.23: Another System Definition Facility. +;;; This is ASDF 2.24: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . @@ -50,7 +50,7 @@ (cl:in-package :common-lisp-user) #+genera (in-package :future-common-lisp-user) -#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl) +#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "ASDF is not supported on your implementation. Please help us port it.") ;;;; Create and setup packages in a way that is compatible with hot-upgrade. @@ -71,8 +71,8 @@ (and (= system::*gcl-major-version* 2) (< system::*gcl-minor-version* 7))) (pushnew :gcl-pre2.7 *features*)) - #+(or abcl (and allegro ics) (and clisp unicode) clozure (and cmu unicode) - (and ecl unicode) lispworks (and sbcl sb-unicode) scl) + #+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode) + clozure lispworks (and sbcl sb-unicode) scl) (pushnew :asdf-unicode *features*) ;;; make package if it doesn't exist yet. ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. @@ -86,6 +86,8 @@ ;;; except that the defun has to be in package asdf. #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t)) #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp)) + #+mkcl (require :cmp) + #+mkcl (setq clos::*redefine-class-in-place* t) ;; Make sure we have strict ANSI class redefinition semantics ;;; Package setup, step 2. (defvar *asdf-version* nil) @@ -116,7 +118,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.23") + (asdf-version "2.24") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -303,7 +305,7 @@ #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*resolve-symlinks* - #:*require-asdf-operator* + #:*load-system-operation* #:*asdf-verbose* #:*verbose-out* @@ -367,11 +369,11 @@ #:appendf #:orf #:length=n-p #:remove-keys #:remove-keyword - #:first-char #:last-char #:ends-with + #:first-char #:last-char #:string-suffix-p #:coerce-name #:directory-pathname-p #:ensure-directory-pathname #:absolute-pathname-p #:ensure-pathname-absolute #:pathname-root - #:getenv #:getenv-pathname #:getenv-pathname + #:getenv #:getenv-pathname #:getenv-pathnames #:getenv-absolute-directory #:getenv-absolute-directories #:probe-file* #:find-symbol* #:strcat @@ -419,6 +421,16 @@ (defparameter +asdf-methods+ '(perform-with-restarts perform explain output-files operation-done-p)) +(defvar *load-system-operation* 'load-op + "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP. +You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle, +or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.") + +(defvar *compile-op-compile-file-function* 'compile-file* + "Function used to compile lisp files.") + + + #+allegro (eval-when (:compile-toplevel :execute) (defparameter *acl-warn-save* @@ -659,7 +671,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 abcl allegro clozure cmu gcl genera lispworks sbcl scl xcl) :unspecific + #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil)) (destructuring-bind (name &optional (type unspecific)) (split-string filename :max 2 :separator ".") @@ -741,8 +753,9 @@ (let ((value (_getenv name))) (unless (ccl:%null-ptr-p value) (ccl:%get-cstring value)))) + #+mkcl (#.(or (find-symbol* 'getenv :si) (find-symbol* 'getenv :mk-ext)) x) #+sbcl (sb-ext:posix-getenv x) - #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl) + #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "~S is not supported on your implementation" 'getenv)) (defun* directory-pathname-p (pathname) @@ -849,7 +862,7 @@ ((zerop i) (return (null l))) ((not (consp l)) (return nil))))) -(defun* ends-with (s suffix) +(defun* string-suffix-p (s suffix) (check-type s string) (check-type suffix string) (let ((start (- (length s) (length suffix)))) @@ -877,7 +890,7 @@ (null nil) (string (probe-file* (parse-namestring p))) (pathname (unless (wild-pathname-p p) - #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks sbcl scl) + #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl) '(probe-file p) #+clisp (aif (find-symbol* '#:probe-pathname :ext) `(ignore-errors (,it p))) @@ -2450,13 +2463,9 @@ (funcall (ensure-function hook) thunk) (funcall thunk)))) -(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 (defmethod perform ((operation compile-op) (c cl-source-file)) - #-:broken-fasl-loader (let ((source-file (component-pathname c)) ;; on some implementations, there are more than one output-file, ;; but the first one should always be the primary fasl that gets loaded. @@ -2489,9 +2498,15 @@ (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)) - #+broken-fasl-loader (list p))) + (let* ((p (lispize-pathname (component-pathname c))) + (f (compile-file-pathname ;; fasl + p #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)) + #+mkcl (o (compile-file-pathname p :fasl-p nil))) ;; object file + #+ecl (if (use-ecl-byte-compiler-p) + (list f) + (list (compile-file-pathname p :type :object) f)) + #+mkcl (list o f) + #-(or ecl mkcl) (list f))) (defmethod perform ((operation compile-op) (c static-file)) (declare (ignorable operation c)) @@ -2532,7 +2547,13 @@ (perform (make-sub-operation c o c 'compile-op) c))))) (defmethod perform ((o load-op) (c cl-source-file)) - (map () #'load (input-files o c))) + (map () #'load + #-(or ecl mkcl) + (input-files o c) + #+(or ecl mkcl) + (loop :for i :in (input-files o c) + :unless (string= (pathname-type i) "fas") + :collect (compile-file-pathname (lispize-pathname i))))) (defmethod perform ((operation load-op) (c static-file)) (declare (ignorable operation c)) @@ -2736,11 +2757,11 @@ (setf (documentation 'operate 'function) operate-docstring)) -(defun* load-system (system &rest args &key force verbose version &allow-other-keys) +(defun* load-system (system &rest keys &key force verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details." (declare (ignore force verbose version)) - (apply 'operate 'load-op system args) + (apply 'operate *load-system-operation* system keys) t) (defun* load-systems (&rest systems) @@ -2752,8 +2773,8 @@ (defun loaded-systems () (remove-if-not 'component-loaded-p (registered-systems))) -(defun require-system (s) - (load-system s :force-not (loaded-systems))) +(defun require-system (s &rest keys &key &allow-other-keys) + (apply 'load-system s :force-not (loaded-systems) keys)) (defun* compile-system (system &rest args &key force verbose version &allow-other-keys) @@ -3096,6 +3117,17 @@ #+mcl (ccl::with-cstrs ((%command command)) (_system %command)) + #+mkcl + ;; This has next to no chance of working on basic Windows! + ;; Your best hope is that Cygwin or MSYS is somewhere in the PATH. + (multiple-value-bind (io process exit-code) + (apply #'mkcl:run-program #+windows "sh" #-windows "/bin/sh" + (list "-c" command) + :input nil :output t #|*verbose-out*|# ;; will be *verbose-out* when we support it + #-windows '(:search nil)) + (declare (ignore io process)) + exit-code) + #+sbcl (sb-ext:process-exit-code (apply 'sb-ext:run-program @@ -3107,7 +3139,7 @@ #+xcl (ext:run-shell-command command) - #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl sbcl scl xcl) + #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl mkcl sbcl scl xcl) (error "RUN-SHELL-COMMAND not implemented for this Lisp"))) #+clisp @@ -3197,7 +3229,7 @@ (defun implementation-type () (first-feature '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu - :ecl :gcl (:lw :lispworks) :mcl :sbcl :scl :symbolics :xcl))) + :ecl :gcl (:lw :lispworks) :mcl :mkcl :sbcl :scl :symbolics :xcl))) (defun operating-system () (first-feature @@ -3232,13 +3264,14 @@ (car ; as opposed to OR, this idiom prevents some unreachable code warning (list #+allegro - (format nil "~A~A~@[~A~]" + (format nil "~A~@[~A~]~@[~A~]~@[~A~]" excl::*common-lisp-version-number* - ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox - (if (eq excl:*current-case-mode* :case-sensitive-lower) "M" "A") + ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default) + (and (eq excl:*current-case-mode* :case-sensitive-lower) "M") ;; Note if not using International ACL ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm - (excl:ics-target-case (:-ics "8"))) + (excl:ics-target-case (:-ics "8")) + (and (member :smp *features*) "S")) #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.) @@ -3272,7 +3305,7 @@ (defun* hostname () ;; Note: untested on RMCL - #+(or abcl clozure cmucl ecl genera lispworks mcl sbcl scl xcl) (machine-instance) + #+(or abcl clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance) #+cormanlisp "localhost" ;; is there a better way? Does it matter? #+allegro (excl.osi:gethostname) #+clisp (first (split-string (machine-instance) :separator " ")) @@ -3304,14 +3337,14 @@ (loop :for dir :in (split-string x :separator (string (inter-directory-separator))) :collect (apply 'ensure-pathname* dir want-absolute want-directory fmt args))) -(defun getenv-pathname (x &key want-absolute want-directory &aux (s (getenv x))) +(defun* getenv-pathname (x &key want-absolute want-directory &aux (s (getenv x))) (ensure-pathname* s want-absolute want-directory "from (getenv ~S)" x)) -(defun getenv-pathnames (x &key want-absolute want-directory &aux (s (getenv x))) +(defun* getenv-pathnames (x &key want-absolute want-directory &aux (s (getenv x))) (and (plusp (length s)) (split-pathnames* s want-absolute want-directory "from (getenv ~S) = ~S" x s))) -(defun getenv-absolute-directory (x) +(defun* getenv-absolute-directory (x) (getenv-pathname x :want-absolute t :want-directory t)) -(defun getenv-absolute-directories (x) +(defun* getenv-absolute-directories (x) (getenv-pathnames x :want-absolute t :want-directory t)) @@ -3698,7 +3731,8 @@ #+sbcl ,(let ((h (getenv-pathname "SBCL_HOME" :want-directory t))) (when h `((,(truenamize h) ,*wild-inferiors*) ()))) ;; The below two are not needed: no precompiled ASDF system there - #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) + #+(or ecl mkcl) (,(translate-logical-pathname "SYS:**;*.*") ()) + #+mkcl (,(translate-logical-pathname "CONTRIB:") ()) ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ;; All-import, here is where we want user stuff to be: :inherit-configuration @@ -3954,11 +3988,11 @@ (default-toplevel-directory (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ??? (include-per-user-information nil) - (map-all-source-files (or #+(or ecl clisp) t nil)) + (map-all-source-files (or #+(or clisp ecl mkcl) t nil)) (source-to-target-mappings nil)) - #+(or ecl clisp) + #+(or clisp ecl mkcl) (when (null map-all-source-files) - (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP")) + (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL")) (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp"))) (mapped-files (if map-all-source-files *wild-file* (make-pathname :type fasl-type :defaults *wild-file*))) @@ -4161,7 +4195,7 @@ string)) (setf inherit t) (push ':inherit-configuration directives)) - ((ends-with s "//") ;; TODO: allow for doubling of separator even outside Unix? + ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix? (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives)) (t (push `(:directory ,(check s)) directives)))) @@ -4192,6 +4226,7 @@ (defun* wrapping-source-registry () `(:source-registry + #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:")) #+sbcl (:tree ,(truenamize (getenv-pathname "SBCL_HOME" :want-directory t))) :inherit-configuration #+cmu (:tree #p"modules:") @@ -4200,23 +4235,23 @@ `(:source-registry #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/")) (:directory ,(default-directory)) - ,@(loop :for dir :in - `(,@(when (os-unix-p) - `(,(or (getenv-absolute-directory "XDG_DATA_HOME") - (subpathname (user-homedir) ".local/share/")) - ,@(or (getenv-absolute-directories "XDG_DATA_DIRS") - '("/usr/local/share" "/usr/share")))) - ,@(when (os-windows-p) - `(,(or #+lispworks (sys:get-folder-path :local-appdata) - (getenv-absolute-directory "LOCALAPPDATA")) - ,(or #+lispworks (sys:get-folder-path :appdata) - (getenv-absolute-directory "APPDATA")) - ,(or #+lispworks (sys:get-folder-path :common-appdata) - (getenv-absolute-directory "ALLUSERSAPPDATA") - (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))) - :collect `(:directory ,(subpathname* dir "common-lisp/systems/")) - :collect `(:tree ,(subpathname* dir "common-lisp/source/"))) - :inherit-configuration)) + ,@(loop :for dir :in + `(,@(when (os-unix-p) + `(,(or (getenv-absolute-directory "XDG_DATA_HOME") + (subpathname (user-homedir) ".local/share/")) + ,@(or (getenv-absolute-directories "XDG_DATA_DIRS") + '("/usr/local/share" "/usr/share")))) + ,@(when (os-windows-p) + `(,(or #+lispworks (sys:get-folder-path :local-appdata) + (getenv-absolute-directory "LOCALAPPDATA")) + ,(or #+lispworks (sys:get-folder-path :appdata) + (getenv-absolute-directory "APPDATA")) + ,(or #+lispworks (sys:get-folder-path :common-appdata) + (getenv-absolute-directory "ALLUSERSAPPDATA") + (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))) + :collect `(:directory ,(subpathname* dir "common-lisp/systems/")) + :collect `(:tree ,(subpathname* dir "common-lisp/source/"))) + :inherit-configuration)) (defun* user-source-registry (&key (direction :input)) (in-user-configuration-directory *source-registry-file* :direction direction)) (defun* system-source-registry (&key (direction :input)) @@ -4362,51 +4397,56 @@ (clear-output-translations)) -;;; ECL support for COMPILE-OP / LOAD-OP +;;; ECL and MKCL support for COMPILE-OP / LOAD-OP ;;; -;;; In ECL, these operations produce both FASL files and the -;;; object files that they are built from. Having both of them allows -;;; us to later on reuse the object files for bundles, libraries, -;;; standalone executables, etc. +;;; In ECL and MKCL, these operations produce both +;;; FASL files and the object files that they are built from. +;;; Having both of them allows us to later on reuse the object files +;;; for bundles, libraries, standalone executables, etc. ;;; ;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes ;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp. ;;; -#+ecl +;;; Also, register-pre-built-system. + +#+(or ecl mkcl) (progn - (setf *compile-op-compile-file-function* 'ecl-compile-file) + (defun register-pre-built-system (name) + (register-system (make-instance 'system :name (coerce-name name) :source-file nil))) - (defun ecl-compile-file (input-file &rest keys &key &allow-other-keys) - (if (use-ecl-byte-compiler-p) - (apply 'compile-file* input-file keys) - (multiple-value-bind (object-file flags1 flags2) - (apply 'compile-file* input-file :system-p t keys) - (values (and object-file - (c::build-fasl (compile-file-pathname object-file :type :fasl) - :lisp-files (list object-file)) - object-file) - flags1 - flags2)))) - - (defmethod output-files ((operation compile-op) (c cl-source-file)) - (declare (ignorable operation)) - (let* ((p (lispize-pathname (component-pathname c))) - (f (compile-file-pathname p :type :fasl))) - (if (use-ecl-byte-compiler-p) - (list f) - (list (compile-file-pathname p :type :object) f)))) - - (defmethod perform ((o load-op) (c cl-source-file)) - (map () #'load - (loop :for i :in (input-files o c) - :unless (string= (pathname-type i) "fas") - :collect (compile-file-pathname (lispize-pathname i)))))) + #+(or (and ecl win32) (and mkcl windows)) + (unless (assoc "asd" #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal) + (appendf #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source)))) + + (setf #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions* + (loop :for f :in #+ecl ext:*module-provider-functions* + #+mkcl mk-ext::*module-provider-functions* + :unless (eq f 'module-provide-asdf) + :collect #'(lambda (name) + (let ((l (multiple-value-list (funcall f name)))) + (and (first l) (register-pre-built-system (coerce-name name))) + (values-list l))))) + + (setf *compile-op-compile-file-function* 'compile-file-keeping-object) + + (defun compile-file-keeping-object (input-file &rest keys &key &allow-other-keys) + (#+ecl if #+ecl (use-ecl-byte-compiler-p) #+ecl (apply 'compile-file* input-file keys) + #+mkcl progn + (multiple-value-bind (object-file flags1 flags2) + (apply 'compile-file* input-file + #+ecl :system-p #+ecl t #+mkcl :fasl-p #+mkcl nil keys) + (values (and object-file + (compiler::build-fasl + (compile-file-pathname object-file + #+ecl :type #+ecl :fasl #+mkcl :fasl-p #+mkcl t) + #+ecl :lisp-files #+mkcl :lisp-object-files (list object-file)) + object-file) + flags1 + flags2))))) -;;;; ----------------------------------------------------------------- -;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL +;;;; ----------------------------------------------------------------------- +;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL ;;;; -(defvar *require-asdf-operator* 'load-op) - (defun* module-provide-asdf (name) (handler-bind ((style-warning #'muffle-warning) @@ -4418,10 +4458,10 @@ (let ((*verbose-out* (make-broadcast-stream)) (system (find-system (string-downcase name) nil))) (when system - (operate *require-asdf-operator* system :verbose nil :force-not (loaded-systems)) + (require-system system :verbose nil) t)))) -#+(or abcl clisp clozure cmu ecl sbcl) +#+(or abcl clisp clozure cmu ecl mkcl sbcl) (let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom)))) (when x (eval `(pushnew 'module-provide-asdf @@ -4429,6 +4469,7 @@ #+clisp ,x #+clozure ccl:*module-provider-functions* #+(or cmu ecl) ext:*module-provider-functions* + #+mkcl mk-ext:*module-provider-functions* #+sbcl sb-ext:*module-provider-functions*)))) @@ -4448,6 +4489,21 @@ (when *load-verbose* (asdf-message ";; ASDF, version ~a~%" (asdf-version))) +#+mkcl +(progn + (defvar *loading-asdf-bundle* nil) + (unless *loading-asdf-bundle* + (let ((*central-registry* + (cons (translate-logical-pathname #P"CONTRIB:asdf-bundle;") *central-registry*)) + (*loading-asdf-bundle* t)) + (clear-system :asdf-bundle) ;; we hope to force a reload. + (multiple-value-bind (result bundling-error) + (ignore-errors (asdf:oos 'asdf:load-op :asdf-bundle)) + (unless result + (format *error-output* + "~&;;; ASDF: Failed to load package 'asdf-bundle'!~%;;; ASDF: Reason is: ~A.~%" + bundling-error)))))) + #+allegro (eval-when (:compile-toplevel :execute) (when (boundp 'excl:*warn-on-nested-reader-conditionals*) From mevenson at common-lisp.net Wed Sep 12 13:23:43 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 12 Sep 2012 06:23:43 -0700 Subject: [armedbear-cvs] r14151 - trunk/abcl/doc/design/pathnames Message-ID: Author: mevenson Date: Wed Sep 12 06:23:41 2012 New Revision: 14151 Log: Draft of analysis of Pathname merge semantics problems. This problem seems to be at the root of loading JNA. Added: trunk/abcl/doc/design/pathnames/merging-defaults.markdown Added: trunk/abcl/doc/design/pathnames/merging-defaults.markdown ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/doc/design/pathnames/merging-defaults.markdown Wed Sep 12 06:23:41 2012 (r14151) @@ -0,0 +1,31 @@ +If *DEFAULT-PATHNAME-DEFAULTS* is a JAR-PATHNAME, commands like + + CL-USER: (probe-file #"/") + +will fail. + +## Other implementations + +### SBCL + +A host nonce which appears in the reader as +#. (Is there a different one under +Windows?) + +### CLISP + +HOST is NIL. + + +### CCL + +HOST is :UNSPECIFIC. + + +### ECL + +HOST is NIL. + + + + From mevenson at common-lisp.net Fri Sep 14 22:09:15 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 14 Sep 2012 15:09:15 -0700 Subject: [armedbear-cvs] r14152 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Sep 14 15:09:14 2012 New Revision: 14152 Log: ENSURE-DIRECTORIES-EXIST should be operating on Pathnames not namestrings. More informative error message when creating a directory fails. Modified: trunk/abcl/src/org/armedbear/lisp/ensure-directories-exist.lisp Modified: trunk/abcl/src/org/armedbear/lisp/ensure-directories-exist.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ensure-directories-exist.lisp Wed Sep 12 06:23:41 2012 (r14151) +++ trunk/abcl/src/org/armedbear/lisp/ensure-directories-exist.lisp Fri Sep 14 15:09:14 2012 (r14152) @@ -33,7 +33,7 @@ (in-package "SYSTEM") -(defun ensure-directories-exist (pathspec &key verbose) +(defun ensure-directories-exist (pathspec &key (verbose t)) ;; DEBUG (let ((pathname (pathname pathspec)) (created-p nil)) ;;; CLHS: Function ENSURE-DIRECTORIES-EXIST "An error of type @@ -46,23 +46,24 @@ :format-control "Bad place for a wild HOST, DEVICE, or DIRECTORY component." :pathname pathname)) (let ((dir (pathname-directory pathname))) - (loop for i from 1 upto (length dir) - do (let ((newpath (make-pathname - :host (pathname-host pathname) - :device (pathname-device pathname) - :directory (subseq dir 0 i)))) - (unless (probe-file newpath) - (let ((namestring (namestring newpath))) - (when verbose - (fresh-line) - (format *standard-output* - "Creating directory: ~A~%" - namestring)) - (mkdir namestring) - (unless (probe-file namestring) - (error 'file-error - :pathname pathspec - :format-control "Can't create directory ~A." - :format-arguments (list namestring))) + (loop :for i :from 1 :upto (length dir) + :doing (let ((newpath (make-pathname + :host (pathname-host pathname) + :device (if (pathname-device pathname) + (pathname-device pathname) + :unspecific) + :directory (subseq dir 0 i)))) + (unless (probe-directory newpath) + (when verbose + (fresh-line) + (format *standard-output* + "Creating directory of pathname ~A.~&" + newpath)) + (mkdir newpath) + (unless (probe-directory newpath) + (error 'file-error + :pathname newpath + :format-control "Can't ensure directory~& ~S ~&ancestor of~& ~S." + :format-arguments (list newpath pathname))) (setq created-p t))))) - (values pathname created-p)))) + (values pathname created-p))) From rschlatte at common-lisp.net Wed Sep 19 14:34:47 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 19 Sep 2012 07:34:47 -0700 Subject: [armedbear-cvs] r14153 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed Sep 19 07:34:44 2012 New Revision: 14153 Log: Initialize shared slots upon class finalization. - Slots with :allocation :class can now be read without creating an instance beforehand. - Reported by Pascal Costanza Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Sep 14 15:09:14 2012 (r14152) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Sep 19 07:34:44 2012 (r14153) @@ -548,9 +548,16 @@ (:class (unless (slot-definition-location slot) (let ((allocation-class (slot-definition-allocation-class slot))) - (setf (slot-definition-location slot) - (if (eq allocation-class class) - (cons (slot-definition-name slot) +slot-unbound+) + (if (eq allocation-class class) + ;; We initialize class slots here so they can be + ;; accessed without creating a dummy instance. + (let ((initfunction (slot-definition-initfunction slot))) + (setf (slot-definition-location slot) + (cons (slot-definition-name slot) + (if initfunction + (funcall initfunction) + +slot-unbound+)))) + (setf (slot-definition-location slot) (slot-location allocation-class (slot-definition-name slot)))))) (push (slot-definition-location slot) shared-slots)))) (when old-layout From rschlatte at common-lisp.net Wed Sep 19 18:58:22 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 19 Sep 2012 11:58:22 -0700 Subject: [armedbear-cvs] r14154 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed Sep 19 11:58:21 2012 New Revision: 14154 Log: Fix slot-boundp-using-class. - Reported by Pascal Costanza Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Sep 19 07:34:44 2012 (r14153) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Sep 19 11:58:21 2012 (r14154) @@ -3474,8 +3474,8 @@ (slot standard-effective-slot-definition)) (let ((location (slot-definition-location slot))) (if (consp location) - (eq (cdr location) +slot-unbound+) ; :allocation :class - (eq (standard-instance-access instance location) +slot-unbound+)))) + (not (eq (cdr location) +slot-unbound+)) ; :allocation :class + (not (eq (standard-instance-access instance location) +slot-unbound+))))) (defmethod slot-boundp-using-class ((class funcallable-standard-class) instance (slot symbol)) @@ -3484,9 +3484,9 @@ (slot standard-effective-slot-definition)) (let ((location (slot-definition-location slot))) (if (consp location) - (eq (cdr location) +slot-unbound+) ; :allocation :class - (eq (funcallable-standard-instance-access instance location) - +slot-unbound+)))) + (not (eq (cdr location) +slot-unbound+)) ; :allocation :class + (not (eq (funcallable-standard-instance-access instance location) + +slot-unbound+))))) (defmethod slot-boundp-using-class ((class structure-class) instance slot) "Structure slots can't be unbound, so this method always returns T." From mevenson at common-lisp.net Sat Sep 29 09:06:26 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 29 Sep 2012 02:06:26 -0700 Subject: [armedbear-cvs] r14155 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat Sep 29 02:06:25 2012 New Revision: 14155 Log: Better diagnostics for CL:MAKE-PATHNAME rules for allowable DEVICE components. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java Wed Sep 19 11:58:21 2012 (r14154) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Sat Sep 29 02:06:25 2012 (r14155) @@ -1324,6 +1324,11 @@ } else if (key == Keyword.DEVICE) { device = value; deviceSupplied = true; + if (!(value instanceof AbstractString + || value.equals(Keyword.UNSPECIFIC) + || value.equals(NIL) + || value instanceof Cons)) + error(new TypeError("DEVICE is not a string, :UNSPECIFIC, NIL, or a list.", value, NIL)); } else if (key == Keyword.DIRECTORY) { directorySupplied = true; if (value instanceof AbstractString) { From ehuelsmann at common-lisp.net Sat Sep 29 20:23:28 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 29 Sep 2012 13:23:28 -0700 Subject: [armedbear-cvs] r14156 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Sep 29 13:23:27 2012 New Revision: 14156 Log: Fix incorrect lambda list reassembly after parsing a DEFMETHOD lambda list. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Sep 29 02:06:25 2012 (r14155) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Sep 29 13:23:27 2012 (r14156) @@ -1916,10 +1916,10 @@ (opts (getf plist :optional-args)) (auxs (getf plist :auxiliary-args))) `(, at requireds + ,@(if opts `(&optional , at opts) ()) ,@(if rv `(&rest ,rv) ()) ,@(if (or ks keysp aok) `(&key , at ks) ()) ,@(if aok '(&allow-other-keys) ()) - ,@(if opts `(&optional , at opts) ()) ,@(if auxs `(&aux , at auxs) ())))) (defun extract-specializer-names (specialized-lambda-list) From ehuelsmann at common-lisp.net Sat Sep 29 21:17:04 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 29 Sep 2012 14:17:04 -0700 Subject: [armedbear-cvs] r14157 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Sep 29 14:17:04 2012 New Revision: 14157 Log: Lambda list keyword ordering checks. Fixed ordering of lambda list keywords in some method defintions: we need to adhere to &rest ... &key ordering ourselves too. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Sep 29 13:23:27 2012 (r14156) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Sep 29 14:17:04 2012 (r14157) @@ -1944,35 +1944,59 @@ (optionals ()) (auxs ()) (allow-other-keys nil) - (state :parsing-required)) + (state :required)) (dolist (arg lambda-list) (if (member arg lambda-list-keywords) (ecase arg (&optional - (setq state :parsing-optional)) + (unless (eq state :required) + (error 'program-error + :format-control "~A followed by &OPTIONAL not allowed ~ + in lambda list ~S" + :format-arguments (list state lambda-list))) + (setq state '&optional)) (&rest - (setq state :parsing-rest)) + (unless (or (eq state :required) + (eq state '&optional)) + (error 'program-error + :format-control "~A followed by &REST not allowed ~ + in lambda list ~S" + :format-arguments (list state lambda-list))) + (setq state '&rest)) (&key + (unless (or (eq state :required) + (eq state '&optional) + (eq state '&rest)) + (error 'program-error + :format-control "~A followed by &KEY not allowed + in lambda list ~S" + :format-arguments (list state lambda-list))) (setq keysp t) - (setq state :parsing-key)) + (setq state '&key)) (&allow-other-keys + (unless (eq state '&key) + (error 'program-error + :format-control "&ALLOW-OTHER-KEYS not allowed while + parsing ~A in lambda list ~S" + :format-arguments (list state lambda-list))) (setq allow-other-keys 't)) (&aux + ;; &aux comes last; any other previous state is fine (setq state :parsing-aux))) (case state - (:parsing-required + (:required (push-on-end arg required-args) (if (listp arg) (progn (push-on-end (car arg) required-names) (push-on-end (cadr arg) specializers)) (progn (push-on-end arg required-names) (push-on-end 't specializers)))) - (:parsing-optional (push-on-end arg optionals)) - (:parsing-rest (setq rest-var arg)) - (:parsing-key + (&optional (push-on-end arg optionals)) + (&rest (setq rest-var arg)) + (&key (push-on-end (get-keyword-from-arg arg) keys) (push-on-end arg key-args)) - (:parsing-aux (push-on-end arg auxs))))) + (&aux (push-on-end arg auxs))))) (list :required-names required-names :required-args required-args :specializers specializers @@ -3143,8 +3167,9 @@ class) (defmethod ensure-class-using-class ((class class) name + &rest all-keys &key (metaclass +the-standard-class+ metaclassp) - direct-superclasses &rest all-keys + direct-superclasses &allow-other-keys) (declare (ignore name)) (setf all-keys (copy-list all-keys)) ; since we modify it @@ -3870,8 +3895,8 @@ (apply #'std-after-initialization-for-classes class args)) (defmethod reinitialize-instance :before ((class standard-class) - &key direct-superclasses - &rest all-keys) + &rest all-keys + &key direct-superclasses) (check-initargs (list #'allocate-instance #'initialize-instance) (list* class all-keys) @@ -3885,8 +3910,8 @@ (add-direct-subclass superclass class))) (defmethod reinitialize-instance :before ((class funcallable-standard-class) - &key direct-superclasses - &rest all-keys) + &rest all-keys + &key direct-superclasses) (check-initargs (list #'allocate-instance #'initialize-instance) (list* class all-keys) From rschlatte at common-lisp.net Sun Sep 30 13:11:08 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 30 Sep 2012 06:11:08 -0700 Subject: [armedbear-cvs] r14158 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Sep 30 06:11:05 2012 New Revision: 14158 Log: Change slot ordering: slots defined in the superclass come first Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Sep 29 14:17:04 2012 (r14157) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Sep 30 06:11:05 2012 (r14158) @@ -675,8 +675,9 @@ ;;; Slot inheritance (defun std-compute-slots (class) - (let* ((all-slots (mapappend #'class-direct-slots - (class-precedence-list class))) + (let* ((all-slots (nreverse ;; Slots of base class should come first + (mapappend #'(lambda (c) (reverse (class-direct-slots c))) + (reverse (class-precedence-list class))))) (all-names (remove-duplicates (mapcar 'slot-definition-name all-slots)))) (mapcar #'(lambda (name) From mevenson at common-lisp.net Sun Sep 30 17:15:06 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 30 Sep 2012 10:15:06 -0700 Subject: [armedbear-cvs] r14159 - trunk/abcl/doc/design/pathnames Message-ID: Author: mevenson Date: Sun Sep 30 10:15:05 2012 New Revision: 14159 Log: Document problems with having *DEFAULT-PATHNAME-DEFAULTS* point to a jar. UC0: happens in loading systems via ASDF recursively in jars (abcl-contrib.jar) Modified: trunk/abcl/doc/design/pathnames/merging-defaults.markdown Modified: trunk/abcl/doc/design/pathnames/merging-defaults.markdown ============================================================================== --- trunk/abcl/doc/design/pathnames/merging-defaults.markdown Sun Sep 30 06:11:05 2012 (r14158) +++ trunk/abcl/doc/design/pathnames/merging-defaults.markdown Sun Sep 30 10:15:05 2012 (r14159) @@ -1,3 +1,10 @@ +# ISSUE MERGE-PATHNAMES with specialization of JAR-PATHNAME and URL-PATHNAME + +## UC0 Loading jna.jar for CFFI via Quicklisp + +This happens in loading systems via ASDF recursively in jars (abcl-contrib.jar) + +## UC1 If *DEFAULT-PATHNAME-DEFAULTS* is a JAR-PATHNAME, commands like CL-USER: (probe-file #"/") @@ -29,3 +36,9 @@ +### Colophon + +Mark +Created: 01-SEP-2012 +Revised: 30-SEP-2012 +