From rschlatte at common-lisp.net Tue Jan 1 22:25:44 2013 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Tue, 01 Jan 2013 14:25:44 -0800 Subject: [armedbear-cvs] r14346 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Tue Jan 1 14:25:37 2013 New Revision: 14346 Log: Move documentation into its own file. Added: trunk/abcl/src/org/armedbear/lisp/documentation.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp Mon Dec 31 02:21:17 2012 (r14345) +++ trunk/abcl/src/org/armedbear/lisp/autoloads-gen.lisp Tue Jan 1 14:25:37 2013 (r14346) @@ -163,7 +163,7 @@ ;; FUNCTIONS (IN-PACKAGE :CL) -(DOLIST (SYSTEM::FS (QUOTE ((("adjoin") ADJOIN) (("apropos") APROPOS-LIST APROPOS) (("arrays") MAKE-ARRAY ADJUST-ARRAY ARRAY-ROW-MAJOR-INDEX BIT SBIT) (("assoc") ASSOC ASSOC-IF ASSOC-IF-NOT RASSOC RASSOC-IF RASSOC-IF-NOT ACONS PAIRLIS COPY-ALIST) (("bit-array-ops") BIT-AND BIT-IOR BIT-XOR BIT-EQV BIT-NAND BIT-NOR BIT-ANDC1 BIT-ANDC2 BIT-ORC1 BIT-ORC2 BIT-NOT) (("boole") BOOLE) (("butlast") BUTLAST NBUTLAST) (("byte-io") WRITE-BYTE READ-BYTE) (("chars") CHAR/= CHAR> CHAR>= CHAR-NOT-EQUAL) (("clos") CLASS-NAME NO-APPLICABLE-METHOD FUNCTION-KEYWORDS SLOT-VALUE SLOT-BOUNDP SLOT-MAKUNBOUND SLOT-EXISTS-P METHOD-QUALIFIERS ENSURE-GENERIC-FUNCTION COMPUTE-APPLICABLE-METHODS DOCUMENTATION SLOT-MISSING SLOT-UNBOUND ALLOCATE-INSTANCE INITIALIZE-INSTANCE REINITIALIZE-INSTANCE CHANGE-CLASS UPDATE-INSTANCE-FOR-DIFFERENT-CLASS MAKE-INSTANCES-OBSOLETE UPDATE-INSTANCE-FOR-REDEFINED-CLASS MAKE-CONDITION INVALID-METHOD-ERROR METHOD-COMBINATION-ERROR FIND-METHOD ADD-METHOD REMOVE-METHOD NO-NEXT-METHOD) (("coerce") COERCE) (("compile-file-pathname") COMPILE-FILE-PATHNAME) (("compile-file") COMPILE-FILE) (("compiler-macro") COMPILER-MACRO-FUNCTION) (("compiler-pass2") COMPILE) (("concatenate") CONCATENATE) (("copy-seq") COPY-SEQ) (("copy-symbol") COPY-SYMBOL) (("count") COUNT COUNT-IF COUNT-IF-NOT) (("debug") INVOKE-DEBUGGER BREAK) (("delete-duplicates") DELETE-DUPLICATES) (("delete") DELETE DELETE-IF DELETE-IF-NOT) (("deposit-field") DEPOSIT-FIELD) (("describe") DESCRIBE) (("directory") DIRECTORY) (("disassemble") DISASSEMBLE) (("dribble") DRIBBLE) (("ed") ED) (("enough-namestring") ENOUGH-NAMESTRING) (("ensure-directories-exist") ENSURE-DIRECTORIES-EXIST) (("fill") FILL) (("find-all-symbols") FIND-ALL-SYMBOLS) (("find") POSITION POSITION-IF POSITION-IF-NOT FIND FIND-IF FIND-IF-NOT) (("format") FORMAT) (("gentemp") GENTEMP) (("inspect") INSPECT) (("lcm") LCM) (("ldb") BYTE BYTE-SIZE BYTE-POSITION LDB LDB-TEST DPB) (("ldiff") LDIFF) (("list-length") LIST-LENGTH) (("list") FIFTH SIXTH SEVENTH EIGHTH NINTH TENTH MAKE-LIST COMPLEMENT CONSTANTLY MEMBER) (("load") LOAD) (("make-hash-table") MAKE-HASH-TABLE) (("make-load-form-saving-slots") MAKE-LOAD-FORM-SAVING-SLOTS) (("make-sequence") MAKE-SEQUENCE) (("make-string-output-stream") MAKE-STRING-OUTPUT-STREAM) (("make-string") MAKE-STRING) (("map-into") MAP-INTO) (("map") MAP) (("map1") MAPCAN MAPL MAPLIST MAPCON) (("mask-field") MASK-FIELD) (("member-if") MEMBER-IF MEMBER-IF-NOT) (("mismatch") BAD-SEQ-LIMIT THE-END THE-START CALL-TEST TEST-ERROR MISMATCH) (("nsubstitute") NSUBSTITUTE NSUBSTITUTE-IF NSUBSTITUTE-IF-NOT) (("numbers") SIGNUM ROUND FFLOOR FCEILING FROUND RATIONALIZE GCD ISQRT FLOAT-PRECISION DECODE-FLOAT CONJUGATE PHASE) (("open") OPEN) (("package") MAKE-PACKAGE IMPORT DELETE-PACKAGE) (("parse-integer") PARSE-INTEGER) (("pathnames") PATHNAME-HOST PATHNAME-DEVICE PATHNAME-DIRECTORY PATHNAME-NAME PATHNAME-TYPE WILD-PATHNAME-P PATHNAME-MATCH-P TRANSLATE-PATHNAME LOGICAL-PATHNAME-TRANSLATIONS TRANSLATE-LOGICAL-PATHNAME LOAD-LOGICAL-PATHNAME-TRANSLATIONS LOGICAL-PATHNAME PARSE-NAMESTRING) (("pprint-dispatch") COPY-PPRINT-DISPATCH SET-PPRINT-DISPATCH PPRINT-DISPATCH) (("pprint") WRITE PRINT PRIN1 PRINC PPRINT WRITE-TO-STRING PRIN1-TO-STRING PRINC-TO-STRING WRITE-CHAR WRITE-STRING WRITE-LINE TERPRI FRESH-LINE FINISH-OUTPUT FORCE-OUTPUT CLEAR-OUTPUT PPRINT-NEWLINE PPRINT-INDENT PPRINT-TAB PPRINT-LINEAR PPRINT-FILL PPRINT-TABULAR) (("proclaim") PROCLAIM) (("query") Y-OR-N-P YES-OR-NO-P) (("read-from-string") READ-FROM-STRING) (("read-sequence") READ-SEQUENCE) (("reduce") REDUCE) (("remove-duplicates") REMOVE-DUPLICATES) (("remove") REMOVE REMOVE-IF REMOVE-IF-NOT) (("replace") REPLACE) (("revappend") REVAPPEND) (("search") SEARCH) (("setf") GET-SETF-EXPANSION) (("sets") UNION NUNION INTERSECTION NINTERSECTION SET-DIFFERENCE NSET-DIFFERENCE SET-EXCLUSIVE-OR NSET-EXCLUSIVE-OR SUBSETP) (("sort") MERGE SORT STABLE-SORT) (("strings") STRING-UPCASE STRING-DOWNCASE STRING-CAPITALIZE NSTRING-UPCASE NSTRING-DOWNCASE NSTRING-CAPITALIZE STRING= STRING/= STRING-EQUAL STRING-NOT-EQUAL STRING< STRING> STRING<= STRING>= STRING-LESSP STRING-GREATERP STRING-NOT-LESSP STRING-NOT-GREATERP STRING-LEFT-TRIM STRING-RIGHT-TRIM STRING-TRIM) (("sublis") SUBLIS NSUBLIS) (("subst") SUBST SUBST-IF SUBST-IF-NOT NSUBST NSUBST-IF NSUBST-IF-NOT) (("substitute") LIST-SUBSTITUTE* VECTOR-SUBSTITUTE* SUBSTITUTE SUBSTITUTE-IF SUBSTITUTE-IF-NOT) (("subtypep") SUBTYPEP) (("tailp") TAILP) (("time") DECODE-UNIVERSAL-TIME GET-DECODED-TIME ENCODE-UNIVERSAL-TIME) (("tree-equal") TREE-EQUAL) (("typep") TYPEP) (("upgraded-complex-part-type") UPGRADED-COMPLEX-PART-TYPE) (("write-sequence") WRITE-SEQUENCE)))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(DOLIST (SYSTEM::FS (QUOTE ((("adjoin") ADJOIN) (("apropos") APROPOS-LIST APROPOS) (("arrays") MAKE-ARRAY ADJUST-ARRAY ARRAY-ROW-MAJOR-INDEX BIT SBIT) (("assoc") ASSOC ASSOC-IF ASSOC-IF-NOT RASSOC RASSOC-IF RASSOC-IF-NOT ACONS PAIRLIS COPY-ALIST) (("bit-array-ops") BIT-AND BIT-IOR BIT-XOR BIT-EQV BIT-NAND BIT-NOR BIT-ANDC1 BIT-ANDC2 BIT-ORC1 BIT-ORC2 BIT-NOT) (("boole") BOOLE) (("butlast") BUTLAST NBUTLAST) (("byte-io") WRITE-BYTE READ-BYTE) (("chars") CHAR/= CHAR> CHAR>= CHAR-NOT-EQUAL) (("clos") CLASS-NAME NO-APPLICABLE-METHOD FUNCTION-KEYWORDS SLOT-VALUE SLOT-BOUNDP SLOT-MAKUNBOUND SLOT-EXISTS-P METHOD-QUALIFIERS ENSURE-GENERIC-FUNCTION COMPUTE-APPLICABLE-METHODS SLOT-MISSING SLOT-UNBOUND ALLOCATE-INSTANCE INITIALIZE-INSTANCE REINITIALIZE-INSTANCE CHANGE-CLASS UPDATE-INSTANCE-FOR-DIFFERENT-CLASS MAKE-INSTANCES-OBSOLETE UPDATE-INSTANCE-FOR-REDEFINED-CLASS MAKE-CONDITION INVALID-METHOD-ERROR METHOD-COMBINATION-ERROR FIND-METHOD ADD-METHOD REMOVE-METHOD NO-NEXT-METHOD) (("coerce") COERCE) (("compile-file-pathname") COMPILE-FILE-PATHNAME) (("compile-file") COMPILE-FILE) (("compiler-macro") COMPILER-MACRO-FUNCTION) (("compiler-pass2") COMPILE) (("concatenate") CONCATENATE) (("copy-seq") COPY-SEQ) (("copy-symbol") COPY-SYMBOL) (("count") COUNT COUNT-IF COUNT-IF-NOT) (("debug") INVOKE-DEBUGGER BREAK) (("delete-duplicates") DELETE-DUPLICATES) (("delete") DELETE DELETE-IF DELETE-IF-NOT) (("deposit-field") DEPOSIT-FIELD) (("describe") DESCRIBE) (("directory") DIRECTORY) (("disassemble") DISASSEMBLE) (("documentation") DOCUMENTATION) (("dribble") DRIBBLE) (("ed") ED) (("enough-namestring") ENOUGH-NAMESTRING) (("ensure-directories-exist") ENSURE-DIRECTORIES-EXIST) (("fill") FILL) (("find-all-symbols") FIND-ALL-SYMBOLS) (("find") POSITION POSITION-IF POSITION-IF-NOT FIND FIND-IF FIND-IF-NOT) (("format") FORMAT) (("gentemp") GENTEMP) (("inspect") INSPECT) (("lcm") LCM) (("ldb") BYTE BYTE-SIZE BYTE-POSITION LDB LDB-TEST DPB) (("ldiff") LDIFF) (("list-length") LIST-LENGTH) (("list") FIFTH SIXTH SEVENTH EIGHTH NINTH TENTH MAKE-LIST COMPLEMENT CONSTANTLY MEMBER) (("load") LOAD) (("make-hash-table") MAKE-HASH-TABLE) (("make-load-form-saving-slots") MAKE-LOAD-FORM-SAVING-SLOTS) (("make-sequence") MAKE-SEQUENCE) (("make-string-output-stream") MAKE-STRING-OUTPUT-STREAM) (("make-string") MAKE-STRING) (("map-into") MAP-INTO) (("map") MAP) (("map1") MAPCAN MAPL MAPLIST MAPCON) (("mask-field") MASK-FIELD) (("member-if") MEMBER-IF MEMBER-IF-NOT) (("mismatch") BAD-SEQ-LIMIT THE-END THE-START CALL-TEST TEST-ERROR MISMATCH) (("nsubstitute") NSUBSTITUTE NSUBSTITUTE-IF NSUBSTITUTE-IF-NOT) (("numbers") SIGNUM ROUND FFLOOR FCEILING FROUND RATIONALIZE GCD ISQRT FLOAT-PRECISION DECODE-FLOAT CONJUGATE PHASE) (("open") OPEN) (("package") MAKE-PACKAGE IMPORT DELETE-PACKAGE) (("parse-integer") PARSE-INTEGER) (("pathnames") PATHNAME-HOST PATHNAME-DEVICE PATHNAME-DIRECTORY PATHNAME-NAME PATHNAME-TYPE WILD-PATHNAME-P PATHNAME-MATCH-P TRANSLATE-PATHNAME LOGICAL-PATHNAME-TRANSLATIONS TRANSLATE-LOGICAL-PATHNAME LOAD-LOGICAL-PATHNAME-TRANSLATIONS LOGICAL-PATHNAME PARSE-NAMESTRING) (("pprint-dispatch") COPY-PPRINT-DISPATCH SET-PPRINT-DISPATCH PPRINT-DISPATCH) (("pprint") WRITE PRINT PRIN1 PRINC PPRINT WRITE-TO-STRING PRIN1-TO-STRING PRINC-TO-STRING WRITE-CHAR WRITE-STRING WRITE-LINE TERPRI FRESH-LINE FINISH-OUTPUT FORCE-OUTPUT CLEAR-OUTPUT PPRINT-NEWLINE PPRINT-INDENT PPRINT-TAB PPRINT-LINEAR PPRINT-FILL PPRINT-TABULAR) (("proclaim") PROCLAIM) (("query") Y-OR-N-P YES-OR-NO-P) (("read-from-string") READ-FROM-STRING) (("read-sequence") READ-SEQUENCE) (("reduce") REDUCE) (("remove-duplicates") REMOVE-DUPLICATES) (("remove") REMOVE REMOVE-IF REMOVE-IF-NOT) (("replace") REPLACE) (("revappend") REVAPPEND) (("search") SEARCH) (("setf") GET-SETF-EXPANSION) (("sets") UNION NUNION INTERSECTION NINTERSECTION SET-DIFFERENCE NSET-DIFFERENCE SET-EXCLUSIVE-OR NSET-EXCLUSIVE-OR SUBSETP) (("sort") MERGE SORT STABLE-SORT) (("strings") STRING-UPCASE STRING-DOWNCASE STRING-CAPITALIZE NSTRING-UPCASE NSTRING-DOWNCASE NSTRING-CAPITALIZE STRING= STRING/= STRING-EQUAL STRING-NOT-EQUAL STRING< STRING> STRING<= STRING>= STRING-LESSP STRING-GREATERP STRING-NOT-LESSP STRING-NOT-GREATERP STRING-LEFT-TRIM STRING-RIGHT-TRIM STRING-TRIM) (("sublis") SUBLIS NSUBLIS) (("subst") SUBST SUBST-IF SUBST-IF-NOT NSUBST NSUBST-IF NSUBST-IF-NOT) (("substitute") LIST-SUBSTITUTE* VECTOR-SUBSTITUTE* SUBSTITUTE SUBSTITUTE-IF SUBSTITUTE-IF-NOT) (("subtypep") SUBTYPEP) (("tailp") TAILP) (("time") DECODE-UNIVERSAL-TIME GET-DECODED-TIME ENCODE-UNIVERSAL-TIME) (("tree-equal") TREE-EQUAL) (("typep") TYPEP) (("upgraded-complex-part-type") UPGRADED-COMPLEX-PART-TYPE) (("write-sequence") WRITE-SEQUENCE)))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) ;; MACROS Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Dec 31 02:21:17 2012 (r14345) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Jan 1 14:25:37 2013 (r14346) @@ -1,7 +1,7 @@ ;;; clos.lisp ;;; ;;; Copyright (C) 2003-2007 Peter Graves -;;; Copyright (C) 2010 Mark Evenson +;;; Copyright (C) 2010-2013 Mark Evenson ;;; $Id$ ;;; ;;; This program is free software; you can redistribute it and/or @@ -3254,133 +3254,6 @@ (declare (ignore initargs)) +the-standard-writer-method-class+) -(atomic-defgeneric documentation (x doc-type) - (:method ((x symbol) doc-type) - (%documentation x doc-type)) - (:method ((x function) doc-type) - (%documentation x doc-type))) - -(atomic-defgeneric (setf documentation) (new-value x doc-type) - (:method (new-value (x symbol) doc-type) - (%set-documentation x doc-type new-value)) - (:method (new-value (x function) doc-type) - (%set-documentation x doc-type new-value))) - - -;; FIXME This should be a weak hashtable! -(defvar *list-documentation-hashtable* (make-hash-table :test #'equal)) - -(defmethod documentation ((x list) (doc-type (eql 'function))) - (let ((alist (gethash x *list-documentation-hashtable*))) - (and alist (cdr (assoc doc-type alist))))) - -(defmethod documentation ((x list) (doc-type (eql 'compiler-macro))) - (let ((alist (gethash x *list-documentation-hashtable*))) - (and alist (cdr (assoc doc-type alist))))) - -(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function))) - (let* ((alist (gethash x *list-documentation-hashtable*)) - (entry (and alist (assoc doc-type alist)))) - (cond (entry - (setf (cdr entry) new-value)) - (t - (setf (gethash x *list-documentation-hashtable*) - (push (cons doc-type new-value) alist))))) - new-value) - -(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'compiler-macro))) - (let* ((alist (gethash x *list-documentation-hashtable*)) - (entry (and alist (assoc doc-type alist)))) - (cond (entry - (setf (cdr entry) new-value)) - (t - (setf (gethash x *list-documentation-hashtable*) - (push (cons doc-type new-value) alist))))) - new-value) - -(defmethod documentation ((x class) (doc-type (eql 't))) - (class-documentation x)) - -(defmethod documentation ((x class) (doc-type (eql 'type))) - (class-documentation x)) - -(defmethod (setf documentation) (new-value (x class) (doc-type (eql 't))) - (%set-class-documentation x new-value)) - -(defmethod (setf documentation) (new-value (x class) (doc-type (eql 'type))) - (%set-class-documentation x new-value)) - -(defmethod documentation ((x structure-class) (doc-type (eql 't))) - (%documentation x t)) - -(defmethod documentation ((x structure-class) (doc-type (eql 'type))) - (%documentation x t)) - -(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 't))) - (%set-documentation x t new-value)) - -(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 'type))) - (%set-documentation x t new-value)) - -(defmethod documentation ((x standard-generic-function) (doc-type (eql 't))) - (generic-function-documentation x)) - -(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 't))) - (setf (generic-function-documentation x) new-value)) - -(defmethod documentation ((x standard-generic-function) (doc-type (eql 'function))) - (generic-function-documentation x)) - -(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 'function))) - (setf (generic-function-documentation x) new-value)) - -(defmethod documentation ((x standard-method) (doc-type (eql 't))) - (method-documentation x)) - -(defmethod (setf documentation) (new-value (x standard-method) (doc-type (eql 't))) - (setf (method-documentation x) new-value)) - -(defmethod documentation ((x standard-slot-definition) (doc-type (eql 't))) - (slot-definition-documentation x)) - -(defmethod (setf documentation) (new-value (x standard-slot-definition) (doc-type (eql 't))) - (setf (slot-definition-documentation x) new-value)) - -(defmethod documentation ((x package) (doc-type (eql 't))) - (%documentation x doc-type)) - -(defmethod (setf documentation) (new-value (x package) (doc-type (eql 't))) - (%set-documentation x doc-type new-value)) - -(defmethod documentation ((x symbol) (doc-type (eql 'function))) - (if (and (fboundp x) (typep (fdefinition x) 'generic-function)) - (documentation (fdefinition x) doc-type) - (%documentation x doc-type))) - -(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'function))) - (if (and (fboundp x) (typep (fdefinition x) 'generic-function)) - (setf (documentation (fdefinition x) 'function) new-value) - (%set-documentation x 'function new-value))) - -(defmethod documentation ((x symbol) (doc-type (eql 'type))) - (let ((class (find-class x nil))) - (if class - (documentation class t) - (%documentation x 'type)))) - -(defmethod documentation ((x symbol) (doc-type (eql 'structure))) - (%documentation x 'structure)) - -(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type))) - (let ((class (find-class x nil))) - (if class - (setf (documentation class t) new-value) - (%set-documentation x 'type new-value)))) - -(defmethod (setf documentation) (new-value (x symbol) - (doc-type (eql 'structure))) - (%set-documentation x 'structure new-value)) - ;;; Applicable methods (atomic-defgeneric compute-applicable-methods (gf args) Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Mon Dec 31 02:21:17 2012 (r14345) +++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Tue Jan 1 14:25:37 2013 (r14346) @@ -343,6 +343,7 @@ "do-external-symbols.lisp" "do-symbols.lisp" "do.lisp" + "documentation.lisp" "dolist.lisp" "dotimes.lisp" "dribble.lisp" Added: trunk/abcl/src/org/armedbear/lisp/documentation.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/src/org/armedbear/lisp/documentation.lisp Tue Jan 1 14:25:37 2013 (r14346) @@ -0,0 +1,169 @@ +;;; documentation.lisp +;;; +;;; Copyright (C) 2003-2007 Peter Graves +;;; Copyright (C) 2010-2013 Mark Evenson +;;; +;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, 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. + + +(in-package #:mop) + +(require "CLOS") + +(defgeneric documentation (x doc-type) + (:method ((x symbol) doc-type) + (%documentation x doc-type)) + (:method ((x function) doc-type) + (%documentation x doc-type))) + +(defgeneric (setf documentation) (new-value x doc-type) + (:method (new-value (x symbol) doc-type) + (%set-documentation x doc-type new-value)) + (:method (new-value (x function) doc-type) + (%set-documentation x doc-type new-value))) + + +;; FIXME This should be a weak hashtable! +(defvar *list-documentation-hashtable* (make-hash-table :test #'equal)) + +(defmethod documentation ((x list) (doc-type (eql 'function))) + (let ((alist (gethash x *list-documentation-hashtable*))) + (and alist (cdr (assoc doc-type alist))))) + +(defmethod documentation ((x list) (doc-type (eql 'compiler-macro))) + (let ((alist (gethash x *list-documentation-hashtable*))) + (and alist (cdr (assoc doc-type alist))))) + +(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function))) + (let* ((alist (gethash x *list-documentation-hashtable*)) + (entry (and alist (assoc doc-type alist)))) + (cond + (entry (setf (cdr entry) new-value)) + (t (setf (gethash x *list-documentation-hashtable*) + (push (cons doc-type new-value) alist))))) + new-value) + +(defmethod (setf documentation) (new-value (x list) + (doc-type (eql 'compiler-macro))) + (let* ((alist (gethash x *list-documentation-hashtable*)) + (entry (and alist (assoc doc-type alist)))) + (cond + (entry (setf (cdr entry) new-value)) + (t (setf (gethash x *list-documentation-hashtable*) + (push (cons doc-type new-value) alist))))) + new-value) + +(defmethod documentation ((x class) (doc-type (eql 't))) + (class-documentation x)) + +(defmethod documentation ((x class) (doc-type (eql 'type))) + (class-documentation x)) + +(defmethod (setf documentation) (new-value (x class) (doc-type (eql 't))) + (%set-class-documentation x new-value)) + +(defmethod (setf documentation) (new-value (x class) (doc-type (eql 'type))) + (%set-class-documentation x new-value)) + +(defmethod documentation ((x structure-class) (doc-type (eql 't))) + (%documentation x t)) + +(defmethod documentation ((x structure-class) (doc-type (eql 'type))) + (%documentation x t)) + +(defmethod (setf documentation) (new-value (x structure-class) + (doc-type (eql 't))) + (%set-documentation x t new-value)) + +(defmethod (setf documentation) (new-value (x structure-class) + (doc-type (eql 'type))) + (%set-documentation x t new-value)) + +(defmethod documentation ((x standard-generic-function) (doc-type (eql 't))) + (generic-function-documentation x)) + +(defmethod (setf documentation) (new-value (x standard-generic-function) + (doc-type (eql 't))) + (setf (generic-function-documentation x) new-value)) + +(defmethod documentation ((x standard-generic-function) + (doc-type (eql 'function))) + (generic-function-documentation x)) + +(defmethod (setf documentation) (new-value (x standard-generic-function) + (doc-type (eql 'function))) + (setf (generic-function-documentation x) new-value)) + +(defmethod documentation ((x standard-method) (doc-type (eql 't))) + (method-documentation x)) + +(defmethod (setf documentation) (new-value (x standard-method) + (doc-type (eql 't))) + (setf (method-documentation x) new-value)) + +(defmethod documentation ((x standard-slot-definition) (doc-type (eql 't))) + (slot-definition-documentation x)) + +(defmethod (setf documentation) (new-value (x standard-slot-definition) + (doc-type (eql 't))) + (setf (slot-definition-documentation x) new-value)) + +(defmethod documentation ((x package) (doc-type (eql 't))) + (%documentation x doc-type)) + +(defmethod (setf documentation) (new-value (x package) (doc-type (eql 't))) + (%set-documentation x doc-type new-value)) + +(defmethod documentation ((x symbol) (doc-type (eql 'function))) + (if (and (fboundp x) (typep (fdefinition x) 'generic-function)) + (documentation (fdefinition x) doc-type) + (%documentation x doc-type))) + +(defmethod (setf documentation) (new-value (x symbol) + (doc-type (eql 'function))) + (if (and (fboundp x) (typep (fdefinition x) 'generic-function)) + (setf (documentation (fdefinition x) 'function) new-value) + (%set-documentation x 'function new-value))) + +(defmethod documentation ((x symbol) (doc-type (eql 'type))) + (let ((class (find-class x nil))) + (if class + (documentation class t) + (%documentation x 'type)))) + +(defmethod documentation ((x symbol) (doc-type (eql 'structure))) + (%documentation x 'structure)) + +(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type))) + (let ((class (find-class x nil))) + (if class + (setf (documentation class t) new-value) + (%set-documentation x 'type new-value)))) + +(defmethod (setf documentation) (new-value (x symbol) + (doc-type (eql 'structure))) + (%set-documentation x 'structure new-value)) From rschlatte at common-lisp.net Sat Jan 5 18:39:30 2013 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sat, 05 Jan 2013 10:39:30 -0800 Subject: [armedbear-cvs] r14347 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sat Jan 5 10:39:28 2013 New Revision: 14347 Log: defer checking for lambda list congruence. - fixes #284 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 Tue Jan 1 14:25:37 2013 (r14346) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Jan 5 10:39:28 2013 (r14347) @@ -3843,6 +3843,17 @@ &rest all-keys) (apply #'std-after-reinitialization-for-classes class all-keys)) +(defmethod reinitialize-instance :before ((gf standard-generic-function) + &key + (lambda-list nil lambda-list-supplied-p) + &allow-other-keys) + (when lambda-list-supplied-p + (unless (or (null (generic-function-methods gf)) + (lambda-lists-congruent-p lambda-list + (generic-function-lambda-list gf))) + (error "The lambda list ~S is incompatible with the existing methods of ~S." + lambda-list gf)))) + (defmethod reinitialize-instance :after ((gf standard-generic-function) &rest all-keys) (map-dependents gf #'(lambda (dep) (update-dependent gf dep all-keys)))) @@ -4431,7 +4442,6 @@ function-name &rest all-keys &key (generic-function-class (class-of generic-function)) - (lambda-list nil lambda-list-supplied-p) (method-class (generic-function-method-class generic-function)) (method-combination (generic-function-method-combination generic-function)) &allow-other-keys) @@ -4443,16 +4453,10 @@ (unless (eq generic-function-class (class-of generic-function)) (error "The class ~S is incompatible with the existing class (~S) of ~S." generic-function-class (class-of generic-function) generic-function)) - (when lambda-list-supplied-p - (unless (or (null (generic-function-methods generic-function)) - (lambda-lists-congruent-p lambda-list - (generic-function-lambda-list generic-function))) - (error "The lambda list ~S is incompatible with the existing methods of ~S." - lambda-list generic-function))) - (unless (or (null (generic-function-methods generic-function)) - (eq method-class (generic-function-method-class generic-function))) - (error "The method class ~S is incompatible with the existing methods of ~S." - method-class generic-function)) + ;; We used to check for changes in method class here, but CLHS says: + ;; "If function-name specifies a generic function that has a different + ;; value for the :method-class argument, the value is changed, but any + ;; existing methods are not changed." (unless (typep method-combination 'method-combination) (setf method-combination (find-method-combination generic-function From mevenson at common-lisp.net Sun Jan 6 07:45:32 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 05 Jan 2013 23:45:32 -0800 Subject: [armedbear-cvs] r14348 - branches/1.1.x/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat Jan 5 23:45:29 2013 New Revision: 14348 Log: Backport r14347 | rschlatte | 2013-01-05 19:39:28 +0100 (Sat, 05 Jan 2013) | 3 lines defer checking for lambda list congruence. - fixes #284 Modified: branches/1.1.x/src/org/armedbear/lisp/clos.lisp Modified: branches/1.1.x/src/org/armedbear/lisp/clos.lisp ============================================================================== --- branches/1.1.x/src/org/armedbear/lisp/clos.lisp Sat Jan 5 10:39:28 2013 (r14347) +++ branches/1.1.x/src/org/armedbear/lisp/clos.lisp Sat Jan 5 23:45:29 2013 (r14348) @@ -3970,6 +3970,17 @@ &rest all-keys) (apply #'std-after-reinitialization-for-classes class all-keys)) +(defmethod reinitialize-instance :before ((gf standard-generic-function) + &key + (lambda-list nil lambda-list-supplied-p) + &allow-other-keys) + (when lambda-list-supplied-p + (unless (or (null (generic-function-methods gf)) + (lambda-lists-congruent-p lambda-list + (generic-function-lambda-list gf))) + (error "The lambda list ~S is incompatible with the existing methods of ~S." + lambda-list gf)))) + (defmethod reinitialize-instance :after ((gf standard-generic-function) &rest all-keys) (map-dependents gf #'(lambda (dep) (update-dependent gf dep all-keys)))) @@ -4558,7 +4569,6 @@ function-name &rest all-keys &key (generic-function-class (class-of generic-function)) - (lambda-list nil lambda-list-supplied-p) (method-class (generic-function-method-class generic-function)) (method-combination (generic-function-method-combination generic-function)) &allow-other-keys) @@ -4570,16 +4580,10 @@ (unless (eq generic-function-class (class-of generic-function)) (error "The class ~S is incompatible with the existing class (~S) of ~S." generic-function-class (class-of generic-function) generic-function)) - (when lambda-list-supplied-p - (unless (or (null (generic-function-methods generic-function)) - (lambda-lists-congruent-p lambda-list - (generic-function-lambda-list generic-function))) - (error "The lambda list ~S is incompatible with the existing methods of ~S." - lambda-list generic-function))) - (unless (or (null (generic-function-methods generic-function)) - (eq method-class (generic-function-method-class generic-function))) - (error "The method class ~S is incompatible with the existing methods of ~S." - method-class generic-function)) + ;; We used to check for changes in method class here, but CLHS says: + ;; "If function-name specifies a generic function that has a different + ;; value for the :method-class argument, the value is changed, but any + ;; existing methods are not changed." (unless (typep method-combination 'method-combination) (setf method-combination (find-method-combination generic-function From mevenson at common-lisp.net Sun Jan 6 07:50:00 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 05 Jan 2013 23:50:00 -0800 Subject: [armedbear-cvs] r14349 - branches/1.1.x/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat Jan 5 23:49:58 2013 New Revision: 14349 Log: Backport r14346 | rschlatte | 2013-01-01 23:25:37 +0100 (Tue, 01 Jan 2013) | 1 line. Added: branches/1.1.x/src/org/armedbear/lisp/documentation.lisp Modified: branches/1.1.x/src/org/armedbear/lisp/autoloads-gen.lisp branches/1.1.x/src/org/armedbear/lisp/clos.lisp branches/1.1.x/src/org/armedbear/lisp/compile-system.lisp Modified: branches/1.1.x/src/org/armedbear/lisp/autoloads-gen.lisp ============================================================================== --- branches/1.1.x/src/org/armedbear/lisp/autoloads-gen.lisp Sat Jan 5 23:45:29 2013 (r14348) +++ branches/1.1.x/src/org/armedbear/lisp/autoloads-gen.lisp Sat Jan 5 23:49:58 2013 (r14349) @@ -163,7 +163,7 @@ ;; FUNCTIONS (IN-PACKAGE :CL) -(DOLIST (SYSTEM::FS (QUOTE ((("adjoin") ADJOIN) (("apropos") APROPOS-LIST APROPOS) (("arrays") MAKE-ARRAY ADJUST-ARRAY ARRAY-ROW-MAJOR-INDEX BIT SBIT) (("assoc") ASSOC ASSOC-IF ASSOC-IF-NOT RASSOC RASSOC-IF RASSOC-IF-NOT ACONS PAIRLIS COPY-ALIST) (("bit-array-ops") BIT-AND BIT-IOR BIT-XOR BIT-EQV BIT-NAND BIT-NOR BIT-ANDC1 BIT-ANDC2 BIT-ORC1 BIT-ORC2 BIT-NOT) (("boole") BOOLE) (("butlast") BUTLAST NBUTLAST) (("byte-io") WRITE-BYTE READ-BYTE) (("chars") CHAR/= CHAR> CHAR>= CHAR-NOT-EQUAL) (("clos") CLASS-NAME NO-APPLICABLE-METHOD FUNCTION-KEYWORDS SLOT-VALUE SLOT-BOUNDP SLOT-MAKUNBOUND SLOT-EXISTS-P METHOD-QUALIFIERS ENSURE-GENERIC-FUNCTION COMPUTE-APPLICABLE-METHODS DOCUMENTATION SLOT-MISSING SLOT-UNBOUND ALLOCATE-INSTANCE INITIALIZE-INSTANCE REINITIALIZE-INSTANCE CHANGE-CLASS UPDATE-INSTANCE-FOR-DIFFERENT-CLASS MAKE-INSTANCES-OBSOLETE UPDATE-INSTANCE-FOR-REDEFINED-CLASS MAKE-CONDITION INVALID-METHOD-ERROR METHOD-COMBINATION-ERROR FIND-METHOD ADD-METHOD REMOVE-METHOD NO-NEXT-METHOD) (("coerce") COERCE) (("compile-file-pathname") COMPILE-FILE-PATHNAME) (("compile-file") COMPILE-FILE) (("compiler-macro") COMPILER-MACRO-FUNCTION) (("compiler-pass2") COMPILE) (("concatenate") CONCATENATE) (("copy-seq") COPY-SEQ) (("copy-symbol") COPY-SYMBOL) (("count") COUNT COUNT-IF COUNT-IF-NOT) (("debug") INVOKE-DEBUGGER BREAK) (("delete-duplicates") DELETE-DUPLICATES) (("delete") DELETE DELETE-IF DELETE-IF-NOT) (("deposit-field") DEPOSIT-FIELD) (("describe") DESCRIBE) (("directory") DIRECTORY) (("disassemble") DISASSEMBLE) (("dribble") DRIBBLE) (("ed") ED) (("enough-namestring") ENOUGH-NAMESTRING) (("ensure-directories-exist") ENSURE-DIRECTORIES-EXIST) (("fill") FILL) (("find-all-symbols") FIND-ALL-SYMBOLS) (("find") POSITION POSITION-IF POSITION-IF-NOT FIND FIND-IF FIND-IF-NOT) (("format") FORMAT) (("gentemp") GENTEMP) (("inspect") INSPECT) (("lcm") LCM) (("ldb") BYTE BYTE-SIZE BYTE-POSITION LDB LDB-TEST DPB) (("ldiff") LDIFF) (("list-length") LIST-LENGTH) (("list") FIFTH SIXTH SEVENTH EIGHTH NINTH TENTH MAKE-LIST COMPLEMENT CONSTANTLY MEMBER) (("load") LOAD) (("make-hash-table") MAKE-HASH-TABLE) (("make-load-form-saving-slots") MAKE-LOAD-FORM-SAVING-SLOTS) (("make-sequence") MAKE-SEQUENCE) (("make-string-output-stream") MAKE-STRING-OUTPUT-STREAM) (("make-string") MAKE-STRING) (("map-into") MAP-INTO) (("map") MAP) (("map1") MAPCAN MAPL MAPLIST MAPCON) (("mask-field") MASK-FIELD) (("member-if") MEMBER-IF MEMBER-IF-NOT) (("mismatch") BAD-SEQ-LIMIT THE-END THE-START CALL-TEST TEST-ERROR MISMATCH) (("nsubstitute") NSUBSTITUTE NSUBSTITUTE-IF NSUBSTITUTE-IF-NOT) (("numbers") SIGNUM ROUND FFLOOR FCEILING FROUND RATIONALIZE GCD ISQRT FLOAT-PRECISION DECODE-FLOAT CONJUGATE PHASE) (("open") OPEN) (("package") MAKE-PACKAGE IMPORT DELETE-PACKAGE) (("parse-integer") PARSE-INTEGER) (("pathnames") PATHNAME-HOST PATHNAME-DEVICE PATHNAME-DIRECTORY PATHNAME-NAME PATHNAME-TYPE WILD-PATHNAME-P PATHNAME-MATCH-P TRANSLATE-PATHNAME LOGICAL-PATHNAME-TRANSLATIONS TRANSLATE-LOGICAL-PATHNAME LOAD-LOGICAL-PATHNAME-TRANSLATIONS LOGICAL-PATHNAME PARSE-NAMESTRING) (("pprint-dispatch") COPY-PPRINT-DISPATCH SET-PPRINT-DISPATCH PPRINT-DISPATCH) (("pprint") WRITE PRINT PRIN1 PRINC PPRINT WRITE-TO-STRING PRIN1-TO-STRING PRINC-TO-STRING WRITE-CHAR WRITE-STRING WRITE-LINE TERPRI FRESH-LINE FINISH-OUTPUT FORCE-OUTPUT CLEAR-OUTPUT PPRINT-NEWLINE PPRINT-INDENT PPRINT-TAB PPRINT-LINEAR PPRINT-FILL PPRINT-TABULAR) (("proclaim") PROCLAIM) (("query") Y-OR-N-P YES-OR-NO-P) (("read-from-string") READ-FROM-STRING) (("read-sequence") READ-SEQUENCE) (("reduce") REDUCE) (("remove-duplicates") REMOVE-DUPLICATES) (("remove") REMOVE REMOVE-IF REMOVE-IF-NOT) (("replace") REPLACE) (("revappend") REVAPPEND) (("search") SEARCH) (("setf") GET-SETF-EXPANSION) (("sets") UNION NUNION INTERSECTION NINTERSECTION SET-DIFFERENCE NSET-DIFFERENCE SET-EXCLUSIVE-OR NSET-EXCLUSIVE-OR SUBSETP) (("sort") MERGE SORT STABLE-SORT) (("strings") STRING-UPCASE STRING-DOWNCASE STRING-CAPITALIZE NSTRING-UPCASE NSTRING-DOWNCASE NSTRING-CAPITALIZE STRING= STRING/= STRING-EQUAL STRING-NOT-EQUAL STRING< STRING> STRING<= STRING>= STRING-LESSP STRING-GREATERP STRING-NOT-LESSP STRING-NOT-GREATERP STRING-LEFT-TRIM STRING-RIGHT-TRIM STRING-TRIM) (("sublis") SUBLIS NSUBLIS) (("subst") SUBST SUBST-IF SUBST-IF-NOT NSUBST NSUBST-IF NSUBST-IF-NOT) (("substitute") LIST-SUBSTITUTE* VECTOR-SUBSTITUTE* SUBSTITUTE SUBSTITUTE-IF SUBSTITUTE-IF-NOT) (("subtypep") SUBTYPEP) (("tailp") TAILP) (("time") DECODE-UNIVERSAL-TIME GET-DECODED-TIME ENCODE-UNIVERSAL-TIME) (("tree-equal") TREE-EQUAL) (("typep") TYPEP) (("upgraded-complex-part-type") UPGRADED-COMPLEX-PART-TYPE) (("write-sequence") WRITE-SEQUENCE)))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) +(DOLIST (SYSTEM::FS (QUOTE ((("adjoin") ADJOIN) (("apropos") APROPOS-LIST APROPOS) (("arrays") MAKE-ARRAY ADJUST-ARRAY ARRAY-ROW-MAJOR-INDEX BIT SBIT) (("assoc") ASSOC ASSOC-IF ASSOC-IF-NOT RASSOC RASSOC-IF RASSOC-IF-NOT ACONS PAIRLIS COPY-ALIST) (("bit-array-ops") BIT-AND BIT-IOR BIT-XOR BIT-EQV BIT-NAND BIT-NOR BIT-ANDC1 BIT-ANDC2 BIT-ORC1 BIT-ORC2 BIT-NOT) (("boole") BOOLE) (("butlast") BUTLAST NBUTLAST) (("byte-io") WRITE-BYTE READ-BYTE) (("chars") CHAR/= CHAR> CHAR>= CHAR-NOT-EQUAL) (("clos") CLASS-NAME NO-APPLICABLE-METHOD FUNCTION-KEYWORDS SLOT-VALUE SLOT-BOUNDP SLOT-MAKUNBOUND SLOT-EXISTS-P METHOD-QUALIFIERS ENSURE-GENERIC-FUNCTION COMPUTE-APPLICABLE-METHODS SLOT-MISSING SLOT-UNBOUND ALLOCATE-INSTANCE INITIALIZE-INSTANCE REINITIALIZE-INSTANCE CHANGE-CLASS UPDATE-INSTANCE-FOR-DIFFERENT-CLASS MAKE-INSTANCES-OBSOLETE UPDATE-INSTANCE-FOR-REDEFINED-CLASS MAKE-CONDITION INVALID-METHOD-ERROR METHOD-COMBINATION-ERROR FIND-METHOD ADD-METHOD REMOVE-METHOD NO-NEXT-METHOD) (("coerce") COERCE) (("compile-file-pathname") COMPILE-FILE-PATHNAME) (("compile-file") COMPILE-FILE) (("compiler-macro") COMPILER-MACRO-FUNCTION) (("compiler-pass2") COMPILE) (("concatenate") CONCATENATE) (("copy-seq") COPY-SEQ) (("copy-symbol") COPY-SYMBOL) (("count") COUNT COUNT-IF COUNT-IF-NOT) (("debug") INVOKE-DEBUGGER BREAK) (("delete-duplicates") DELETE-DUPLICATES) (("delete") DELETE DELETE-IF DELETE-IF-NOT) (("deposit-field") DEPOSIT-FIELD) (("describe") DESCRIBE) (("directory") DIRECTORY) (("disassemble") DISASSEMBLE) (("documentation") DOCUMENTATION) (("dribble") DRIBBLE) (("ed") ED) (("enough-namestring") ENOUGH-NAMESTRING) (("ensure-directories-exist") ENSURE-DIRECTORIES-EXIST) (("fill") FILL) (("find-all-symbols") FIND-ALL-SYMBOLS) (("find") POSITION POSITION-IF POSITION-IF-NOT FIND FIND-IF FIND-IF-NOT) (("format") FORMAT) (("gentemp") GENTEMP) (("inspect") INSPECT) (("lcm") LCM) (("ldb") BYTE BYTE-SIZE BYTE-POSITION LDB LDB-TEST DPB) (("ldiff") LDIFF) (("list-length") LIST-LENGTH) (("list") FIFTH SIXTH SEVENTH EIGHTH NINTH TENTH MAKE-LIST COMPLEMENT CONSTANTLY MEMBER) (("load") LOAD) (("make-hash-table") MAKE-HASH-TABLE) (("make-load-form-saving-slots") MAKE-LOAD-FORM-SAVING-SLOTS) (("make-sequence") MAKE-SEQUENCE) (("make-string-output-stream") MAKE-STRING-OUTPUT-STREAM) (("make-string") MAKE-STRING) (("map-into") MAP-INTO) (("map") MAP) (("map1") MAPCAN MAPL MAPLIST MAPCON) (("mask-field") MASK-FIELD) (("member-if") MEMBER-IF MEMBER-IF-NOT) (("mismatch") BAD-SEQ-LIMIT THE-END THE-START CALL-TEST TEST-ERROR MISMATCH) (("nsubstitute") NSUBSTITUTE NSUBSTITUTE-IF NSUBSTITUTE-IF-NOT) (("numbers") SIGNUM ROUND FFLOOR FCEILING FROUND RATIONALIZE GCD ISQRT FLOAT-PRECISION DECODE-FLOAT CONJUGATE PHASE) (("open") OPEN) (("package") MAKE-PACKAGE IMPORT DELETE-PACKAGE) (("parse-integer") PARSE-INTEGER) (("pathnames") PATHNAME-HOST PATHNAME-DEVICE PATHNAME-DIRECTORY PATHNAME-NAME PATHNAME-TYPE WILD-PATHNAME-P PATHNAME-MATCH-P TRANSLATE-PATHNAME LOGICAL-PATHNAME-TRANSLATIONS TRANSLATE-LOGICAL-PATHNAME LOAD-LOGICAL-PATHNAME-TRANSLATIONS LOGICAL-PATHNAME PARSE-NAMESTRING) (("pprint-dispatch") COPY-PPRINT-DISPATCH SET-PPRINT-DISPATCH PPRINT-DISPATCH) (("pprint") WRITE PRINT PRIN1 PRINC PPRINT WRITE-TO-STRING PRIN1-TO-STRING PRINC-TO-STRING WRITE-CHAR WRITE-STRING WRITE-LINE TERPRI FRESH-LINE FINISH-OUTPUT FORCE-OUTPUT CLEAR-OUTPUT PPRINT-NEWLINE PPRINT-INDENT PPRINT-TAB PPRINT-LINEAR PPRINT-FILL PPRINT-TABULAR) (("proclaim") PROCLAIM) (("query") Y-OR-N-P YES-OR-NO-P) (("read-from-string") READ-FROM-STRING) (("read-sequence") READ-SEQUENCE) (("reduce") REDUCE) (("remove-duplicates") REMOVE-DUPLICATES) (("remove") REMOVE REMOVE-IF REMOVE-IF-NOT) (("replace") REPLACE) (("revappend") REVAPPEND) (("search") SEARCH) (("setf") GET-SETF-EXPANSION) (("sets") UNION NUNION INTERSECTION NINTERSECTION SET-DIFFERENCE NSET-DIFFERENCE SET-EXCLUSIVE-OR NSET-EXCLUSIVE-OR SUBSETP) (("sort") MERGE SORT STABLE-SORT) (("strings") STRING-UPCASE STRING-DOWNCASE STRING-CAPITALIZE NSTRING-UPCASE NSTRING-DOWNCASE NSTRING-CAPITALIZE STRING= STRING/= STRING-EQUAL STRING-NOT-EQUAL STRING< STRING> STRING<= STRING>= STRING-LESSP STRING-GREATERP STRING-NOT-LESSP STRING-NOT-GREATERP STRING-LEFT-TRIM STRING-RIGHT-TRIM STRING-TRIM) (("sublis") SUBLIS NSUBLIS) (("subst") SUBST SUBST-IF SUBST-IF-NOT NSUBST NSUBST-IF NSUBST-IF-NOT) (("substitute") LIST-SUBSTITUTE* VECTOR-SUBSTITUTE* SUBSTITUTE SUBSTITUTE-IF SUBSTITUTE-IF-NOT) (("subtypep") SUBTYPEP) (("tailp") TAILP) (("time") DECODE-UNIVERSAL-TIME GET-DECODED-TIME ENCODE-UNIVERSAL-TIME) (("tree-equal") TREE-EQUAL) (("typep") TYPEP) (("upgraded-complex-part-type") UPGRADED-COMPLEX-PART-TYPE) (("write-sequence") WRITE-SEQUENCE)))) (FUNCALL (FUNCTION EXTENSIONS:AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS)))) ;; MACROS Modified: branches/1.1.x/src/org/armedbear/lisp/clos.lisp ============================================================================== --- branches/1.1.x/src/org/armedbear/lisp/clos.lisp Sat Jan 5 23:45:29 2013 (r14348) +++ branches/1.1.x/src/org/armedbear/lisp/clos.lisp Sat Jan 5 23:49:58 2013 (r14349) @@ -1,7 +1,7 @@ ;;; clos.lisp ;;; ;;; Copyright (C) 2003-2007 Peter Graves -;;; Copyright (C) 2010 Mark Evenson +;;; Copyright (C) 2010-2013 Mark Evenson ;;; $Id$ ;;; ;;; This program is free software; you can redistribute it and/or @@ -3254,133 +3254,6 @@ (declare (ignore initargs)) +the-standard-writer-method-class+) -(atomic-defgeneric documentation (x doc-type) - (:method ((x symbol) doc-type) - (%documentation x doc-type)) - (:method ((x function) doc-type) - (%documentation x doc-type))) - -(atomic-defgeneric (setf documentation) (new-value x doc-type) - (:method (new-value (x symbol) doc-type) - (%set-documentation x doc-type new-value)) - (:method (new-value (x function) doc-type) - (%set-documentation x doc-type new-value))) - - -;; FIXME This should be a weak hashtable! -(defvar *list-documentation-hashtable* (make-hash-table :test #'equal)) - -(defmethod documentation ((x list) (doc-type (eql 'function))) - (let ((alist (gethash x *list-documentation-hashtable*))) - (and alist (cdr (assoc doc-type alist))))) - -(defmethod documentation ((x list) (doc-type (eql 'compiler-macro))) - (let ((alist (gethash x *list-documentation-hashtable*))) - (and alist (cdr (assoc doc-type alist))))) - -(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function))) - (let* ((alist (gethash x *list-documentation-hashtable*)) - (entry (and alist (assoc doc-type alist)))) - (cond (entry - (setf (cdr entry) new-value)) - (t - (setf (gethash x *list-documentation-hashtable*) - (push (cons doc-type new-value) alist))))) - new-value) - -(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'compiler-macro))) - (let* ((alist (gethash x *list-documentation-hashtable*)) - (entry (and alist (assoc doc-type alist)))) - (cond (entry - (setf (cdr entry) new-value)) - (t - (setf (gethash x *list-documentation-hashtable*) - (push (cons doc-type new-value) alist))))) - new-value) - -(defmethod documentation ((x class) (doc-type (eql 't))) - (class-documentation x)) - -(defmethod documentation ((x class) (doc-type (eql 'type))) - (class-documentation x)) - -(defmethod (setf documentation) (new-value (x class) (doc-type (eql 't))) - (%set-class-documentation x new-value)) - -(defmethod (setf documentation) (new-value (x class) (doc-type (eql 'type))) - (%set-class-documentation x new-value)) - -(defmethod documentation ((x structure-class) (doc-type (eql 't))) - (%documentation x t)) - -(defmethod documentation ((x structure-class) (doc-type (eql 'type))) - (%documentation x t)) - -(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 't))) - (%set-documentation x t new-value)) - -(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 'type))) - (%set-documentation x t new-value)) - -(defmethod documentation ((x standard-generic-function) (doc-type (eql 't))) - (generic-function-documentation x)) - -(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 't))) - (setf (generic-function-documentation x) new-value)) - -(defmethod documentation ((x standard-generic-function) (doc-type (eql 'function))) - (generic-function-documentation x)) - -(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 'function))) - (setf (generic-function-documentation x) new-value)) - -(defmethod documentation ((x standard-method) (doc-type (eql 't))) - (method-documentation x)) - -(defmethod (setf documentation) (new-value (x standard-method) (doc-type (eql 't))) - (setf (method-documentation x) new-value)) - -(defmethod documentation ((x standard-slot-definition) (doc-type (eql 't))) - (slot-definition-documentation x)) - -(defmethod (setf documentation) (new-value (x standard-slot-definition) (doc-type (eql 't))) - (setf (slot-definition-documentation x) new-value)) - -(defmethod documentation ((x package) (doc-type (eql 't))) - (%documentation x doc-type)) - -(defmethod (setf documentation) (new-value (x package) (doc-type (eql 't))) - (%set-documentation x doc-type new-value)) - -(defmethod documentation ((x symbol) (doc-type (eql 'function))) - (if (and (fboundp x) (typep (fdefinition x) 'generic-function)) - (documentation (fdefinition x) doc-type) - (%documentation x doc-type))) - -(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'function))) - (if (and (fboundp x) (typep (fdefinition x) 'generic-function)) - (setf (documentation (fdefinition x) 'function) new-value) - (%set-documentation x 'function new-value))) - -(defmethod documentation ((x symbol) (doc-type (eql 'type))) - (let ((class (find-class x nil))) - (if class - (documentation class t) - (%documentation x 'type)))) - -(defmethod documentation ((x symbol) (doc-type (eql 'structure))) - (%documentation x 'structure)) - -(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type))) - (let ((class (find-class x nil))) - (if class - (setf (documentation class t) new-value) - (%set-documentation x 'type new-value)))) - -(defmethod (setf documentation) (new-value (x symbol) - (doc-type (eql 'structure))) - (%set-documentation x 'structure new-value)) - ;;; Applicable methods (atomic-defgeneric compute-applicable-methods (gf args) Modified: branches/1.1.x/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- branches/1.1.x/src/org/armedbear/lisp/compile-system.lisp Sat Jan 5 23:45:29 2013 (r14348) +++ branches/1.1.x/src/org/armedbear/lisp/compile-system.lisp Sat Jan 5 23:49:58 2013 (r14349) @@ -343,6 +343,7 @@ "do-external-symbols.lisp" "do-symbols.lisp" "do.lisp" + "documentation.lisp" "dolist.lisp" "dotimes.lisp" "dribble.lisp" Added: branches/1.1.x/src/org/armedbear/lisp/documentation.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ branches/1.1.x/src/org/armedbear/lisp/documentation.lisp Sat Jan 5 23:49:58 2013 (r14349) @@ -0,0 +1,169 @@ +;;; documentation.lisp +;;; +;;; Copyright (C) 2003-2007 Peter Graves +;;; Copyright (C) 2010-2013 Mark Evenson +;;; +;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, 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. + + +(in-package #:mop) + +(require "CLOS") + +(defgeneric documentation (x doc-type) + (:method ((x symbol) doc-type) + (%documentation x doc-type)) + (:method ((x function) doc-type) + (%documentation x doc-type))) + +(defgeneric (setf documentation) (new-value x doc-type) + (:method (new-value (x symbol) doc-type) + (%set-documentation x doc-type new-value)) + (:method (new-value (x function) doc-type) + (%set-documentation x doc-type new-value))) + + +;; FIXME This should be a weak hashtable! +(defvar *list-documentation-hashtable* (make-hash-table :test #'equal)) + +(defmethod documentation ((x list) (doc-type (eql 'function))) + (let ((alist (gethash x *list-documentation-hashtable*))) + (and alist (cdr (assoc doc-type alist))))) + +(defmethod documentation ((x list) (doc-type (eql 'compiler-macro))) + (let ((alist (gethash x *list-documentation-hashtable*))) + (and alist (cdr (assoc doc-type alist))))) + +(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function))) + (let* ((alist (gethash x *list-documentation-hashtable*)) + (entry (and alist (assoc doc-type alist)))) + (cond + (entry (setf (cdr entry) new-value)) + (t (setf (gethash x *list-documentation-hashtable*) + (push (cons doc-type new-value) alist))))) + new-value) + +(defmethod (setf documentation) (new-value (x list) + (doc-type (eql 'compiler-macro))) + (let* ((alist (gethash x *list-documentation-hashtable*)) + (entry (and alist (assoc doc-type alist)))) + (cond + (entry (setf (cdr entry) new-value)) + (t (setf (gethash x *list-documentation-hashtable*) + (push (cons doc-type new-value) alist))))) + new-value) + +(defmethod documentation ((x class) (doc-type (eql 't))) + (class-documentation x)) + +(defmethod documentation ((x class) (doc-type (eql 'type))) + (class-documentation x)) + +(defmethod (setf documentation) (new-value (x class) (doc-type (eql 't))) + (%set-class-documentation x new-value)) + +(defmethod (setf documentation) (new-value (x class) (doc-type (eql 'type))) + (%set-class-documentation x new-value)) + +(defmethod documentation ((x structure-class) (doc-type (eql 't))) + (%documentation x t)) + +(defmethod documentation ((x structure-class) (doc-type (eql 'type))) + (%documentation x t)) + +(defmethod (setf documentation) (new-value (x structure-class) + (doc-type (eql 't))) + (%set-documentation x t new-value)) + +(defmethod (setf documentation) (new-value (x structure-class) + (doc-type (eql 'type))) + (%set-documentation x t new-value)) + +(defmethod documentation ((x standard-generic-function) (doc-type (eql 't))) + (generic-function-documentation x)) + +(defmethod (setf documentation) (new-value (x standard-generic-function) + (doc-type (eql 't))) + (setf (generic-function-documentation x) new-value)) + +(defmethod documentation ((x standard-generic-function) + (doc-type (eql 'function))) + (generic-function-documentation x)) + +(defmethod (setf documentation) (new-value (x standard-generic-function) + (doc-type (eql 'function))) + (setf (generic-function-documentation x) new-value)) + +(defmethod documentation ((x standard-method) (doc-type (eql 't))) + (method-documentation x)) + +(defmethod (setf documentation) (new-value (x standard-method) + (doc-type (eql 't))) + (setf (method-documentation x) new-value)) + +(defmethod documentation ((x standard-slot-definition) (doc-type (eql 't))) + (slot-definition-documentation x)) + +(defmethod (setf documentation) (new-value (x standard-slot-definition) + (doc-type (eql 't))) + (setf (slot-definition-documentation x) new-value)) + +(defmethod documentation ((x package) (doc-type (eql 't))) + (%documentation x doc-type)) + +(defmethod (setf documentation) (new-value (x package) (doc-type (eql 't))) + (%set-documentation x doc-type new-value)) + +(defmethod documentation ((x symbol) (doc-type (eql 'function))) + (if (and (fboundp x) (typep (fdefinition x) 'generic-function)) + (documentation (fdefinition x) doc-type) + (%documentation x doc-type))) + +(defmethod (setf documentation) (new-value (x symbol) + (doc-type (eql 'function))) + (if (and (fboundp x) (typep (fdefinition x) 'generic-function)) + (setf (documentation (fdefinition x) 'function) new-value) + (%set-documentation x 'function new-value))) + +(defmethod documentation ((x symbol) (doc-type (eql 'type))) + (let ((class (find-class x nil))) + (if class + (documentation class t) + (%documentation x 'type)))) + +(defmethod documentation ((x symbol) (doc-type (eql 'structure))) + (%documentation x 'structure)) + +(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type))) + (let ((class (find-class x nil))) + (if class + (setf (documentation class t) new-value) + (%set-documentation x 'type new-value)))) + +(defmethod (setf documentation) (new-value (x symbol) + (doc-type (eql 'structure))) + (%set-documentation x 'structure new-value)) From rschlatte at common-lisp.net Sun Jan 6 18:19:43 2013 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 06 Jan 2013 10:19:43 -0800 Subject: [armedbear-cvs] r14350 - trunk/abcl/doc/manual Message-ID: Author: rschlatte Date: Sun Jan 6 10:19:42 2013 New Revision: 14350 Log: Trial version of the manual in texinfo format Added: trunk/abcl/doc/manual/abcl.texi Added: trunk/abcl/doc/manual/abcl.texi ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/doc/manual/abcl.texi Sun Jan 6 10:19:42 2013 (r14350) @@ -0,0 +1,1722 @@ +\input texinfo + at setfilename abcl.info + at settitle Armed Bear Common Lisp User Manual + at afourpaper + at set EDITION 1.1.0 + + + at c Editing Hints + at c + at c Use emacs. Use M-x texinfo-all-menus-update to update menus. + + + at c Some index prettification helper macros, for tricking the texindex + at c collation "engine" (from sbcl's manual) + at macro earmuffs{name} +*\name\* + at end macro + at macro setf{name} +(setf \name\) + at end macro + + + + at c for install-info + at dircategory Software development + at direntry +* abcl: (abcl). Armed Bear Common Lisp + at end direntry + + at copying + at quotation +This manual is part of ABCL. ABCL is licensed under the terms of the +GPL v2 of June 1991 with the ``classpath-exception'' (see the file + at file{COPYING} in the source distribution for the license, term 13 in +the same file for the classpath exception). This license broadly means +that you must distribute the sources to ABCL, including any changes you +make, together with a program that includes ABCL, but that you are not +required to distribute the sources of the whole program. Submitting +your changes upstream to the ABCL development team is actively +encouraged and very much appreciated, of course. + at end quotation + at end copying + + + at titlepage + at title Armed Bear Common Lisp User Manual + at subtitle Version 1.1.0 + at subtitle December 5, 2012 + at author Mark Evenson + at author Erik H@"ulsmann + at author Rudolf Schlatte + at author Alessio Stalla + at author Ville Voutilainen + + at page + at vskip 0pt plus 1filll + at insertcopying + at end titlepage + + at ifnottex + + at node Top + at top abcl + + at menu +* Introduction:: +* Running ABCL:: +* Interaction with Java:: +* Implementation Dependent Extensions:: +* Beyond ANSI:: +* Contrib:: +* History:: +* Concept Index:: +* Function Index:: +* Variable Index:: +* Type Index:: +* Colophon:: + at end menu + + at end ifnottex + + at contents + + + + + at node Introduction + at chapter Introduction + +Armed Bear Common Lisp (ABCL) is an implementation of Common Lisp that +runs on the Java Virtual Machine. It compiles Common Lisp to Java 5 +bytecode, providing the following integration methods for interfacing +with Java code and libraries: + + at itemize + at item +Lisp code can create Java objects and call their methods. @xref{Calling +from Lisp to Java}. + at item +Java code can call Lisp functions and generic functions, either directly +(@pxref{Calling from Java to Lisp}) or via @t{JSR-223} (@pxref{Java +Scripting API (JSR-223)}). + at item + at code{jinterface-implementation} creates Lisp-side implementations of +Java interfaces that can be used as listeners for Swing classes and +similar. + at end itemize + +ABCL is supported by the Lisp library manager QuickLisp +(@url{http://quicklisp.org/}) and can run many of the programs and +libraries provided therein out-of-the-box. + + + at menu +* Conformance:: +* Contributors:: + at end menu + + at node Conformance + at section Conformance + +ABCL aims to be be a fully conforming ANSI Common Lisp implementation. +Any other behavior should be reported as a bug. ABCL is currently a +(non)-conforming ANSI Common Lisp implementation due to the following +known issues: + + at itemize + at item +The generic function signatures of the @code{DOCUMENTATION} symbol do +not match the specification. + + at item +The @code{TIME} form does not return a proper @code{VALUES} environment +to its caller. + + at item +When merging pathnames and the defaults point to a @code{JAR-PATHNAME}, +we set the @code{DEVICE} of the result to @code{:UNSPECIFIC} if the +pathname to be be merged does not contain a specified @code{DEVICE}, +does not contain a specified @code{HOST}, does contain a relative + at code{DIRECTORY}, and we are not running on a MSFT Windows +platform. at footnote{The intent of this rather arcane sounding deviation +from conformance is so that the result of a merge won't fill in a + at code{DEVICE} with the wrong "default device for the host" in the sense +of the fourth paragraph in the CLHS description of + at code{MERGE-PATHNAMES} (see the paragraph beginning "If the + at code{PATHNAME} explicitly specifies a host and not a device at dots{}"). +A future version of the implementation may return to conformance by +using the @code{HOST} value to reflect the type explicitly.} + + at end itemize + +Somewhat confusingly, this statement of non-conformance in the +accompanying user documentation fulfills the requirements that ABCL is a +conforming ANSI Common Lisp implementation according to the Common Lisp +HyperSpec. Clarifications to this point are solicited. + + + at menu +* Contemporary Common Lisp:: + at end menu + + at node Contemporary Common Lisp + at subsection Contemporary Common Lisp + +In addition to ANSI conformance, ABCL strives to implement features +expected of a contemporary Common Lisp, i.e. a Lisp of the post-2005 +Renaissance. + +The following known problems detract from ABCL being a proper +contemporary Common Lisp. + + at itemize + + at item +An incomplete implementation of interactive debugging mechanisms, namely +a no-op version of @code{STEP}, no support for inspecting local +variables in a given call frame, and no support for resuming a halted +computation at an arbitrarily selected call frame. + + at item +Incomplete streams abstraction, in that ABCL needs suitable abstraction +between ANSI and Gray streams. The streams could be optimized to the +JVM NIO abstractions at great profit for binary byte-level +manipulations. + + at item +Incomplete documentation (missing docstrings from exported symbols +and the draft status of this user manual). + + at end itemize + + + at node Contributors + at section Contributors + + at itemize + at item +Philipp Marek (Thanks for the markup) + + at item +Douglas Miles (Thanks for the whacky IKVM stuff and for keeping the +flame alive in the dark years) + + at item +Alan Ruttenberg (Thanks for JSS) + + at item +and of course + at emph{Peter Graves} + at end itemize + + + + + at node Running ABCL + at chapter Running ABCL + +ABCL is packaged as a single jar file usually named either + at file{abcl.jar} or possibly something like @file{abcl-1.1.0.jar} if +using a versioned package on the local filesystem from your system +vendor. This jar file can be executed from the command line to obtain a +REPL at footnote{Read-Eval Print Loop, a Lisp command-line}, viz: + + at example +cmd$ java -jar abcl.jar + at end example + + at emph{N.b.} for the proceeding command to work, the @code{java} +executable needs to be in your path. + +To facilitate the use of ABCL in tool chains such as SLIME, the Superior +Lisp Interaction Mode for Emacs, we provide both a Bourne shell script +and a @code{DOS} batch file. If you or your administrator adjusted the +path properly, ABCL may be executed simply as: + + at example +cmd$ abcl + at end example + +Probably the easiest way of setting up an editing environment using the +Emacs editor is to use QuickLisp and follow the instructions at + at url{http://www.quicklisp.org/beta/#slime}. + + + at menu +* Options:: +* Initialization:: + at end menu + + at node Options + at section Options + +ABCL supports the following command line options: + + at table @option + at item --help +displays a help message. + + at item --noinform +Suppresses the printing of startup information and banner. + + at item --noinit +suppresses the loading of the @file{~/.abclrc} startup file. + + at item --nosystem +suppresses loading the @file{system.lisp} customization file. + + at item --eval FORM +evaluates @var{FORM} before initializing the REPL. + + at item --load FILE +loads the file @var{FILE} before initializing the REPL. + + at item --load-system-file FILE +loads the system file @var{FILE} before initializing the REPL. + + at item --batch +evaluates forms specified by arguments and in the initialization file + at file{~/.abclrc}, and then exits without starting a REPL. + at end table + +All other command line arguments, as well as all arguments following the +occurrence of a double hyphen (@option{--}) are passed unprocessed into a +list of strings accessible via the variable + at var{ext:*command-line-argument-list*} from within ABCL. + + at defvar @earmuffs{command-line-argument-list} + This variable contains a (possibly empty) list of command-line + arguments. Any arguments that were processed already (e.g., + @option{--load FILE}) are removed from this list. + at end defvar + + + at node Initialization + at section Initialization + +If the ABCL process is started without the @samp{--noinit} flag, it +attempts to load a file named @file{.abclrc} in the user's home +directory and then interpret its contents. + +The user's home directory is determined by the value of the JVM system +property @code{user.home}. This value may or may not correspond +to the value of the @env{HOME} system environment variable, at the +discretion of the JVM implementation that ABCL finds itself +hosted upon. + + + + at node Interaction with Java + at chapter Interaction with Java + +ABCL is a Common Lisp implementation hosted on a Java Virtual Machine. +This chapter describes the mechanisms by which the implementation +interacts with that hosting mechanism. This interactions can go in two +directions: Lisp-to-Java and Java-to-Lisp. + + + at menu +* Calling from Lisp to Java:: +* Calling from Java to Lisp:: +* Java Scripting API (JSR-223):: + at end menu + + at node Calling from Lisp to Java + at section Calling from Lisp to Java + +ABCL offers a number of mechanisms to interact with Java from its +Lisp environment. It allows calling both instance and static methods +of Java objects, manipulation of instance and static fields on Java +objects, and construction of new Java objects. + +When calling Java routines, some values are automatically converted from +Lisp values to Java values. These conversions apply to strings, +integers and floats. Other values need to be converted to their Java +equivalents by the programmer before calling the Java object method. +Java values returned to Lisp are also converted back to their Lisp +counterparts. If this conversion is not desired, certain Lisp-to-Java +functions have ``raw'' counterparts which do not perform any conversion. +These are recognizable by their name ending with @code{-RAW}. + +This section covers the low-level Lisp-to-Java API of ABCL. +Functions in this section are available after evaluating @code{(require +'JAVA)}. A higher level Java API, developed by Alan Ruttenberg, is +available in the @file{contrib/} directory and described later in this +document, @pxref{JSS}. + + + at menu +* Creating Java objects:: +* Accessing Java object and class fields:: +* Calling Java Methods:: +* Calling Java Static Methods:: +* Parameter matching for FFI dynamic dispatch:: +* Implementating Java interfaces in Lisp:: +* Implementation of Java classes in Lisp:: + at end menu + + at node Creating Java objects + at subsection Creating Java objects + +Java objects can be created from Lisp by calling a constructor from the +class of the object to be created. The @code{JAVA:JCONSTRUCTOR} +primitive is used to acquire a constructor reference. + + at defun jconstructor (class-ref &rest parameter-class-refs) + Returns a reference to the Java constructor of @var{CLASS-REF} + accepting the given @var{PARAMETER-CLASS-REFS}. If + @var{PARAMETER-CLASS-REFS} is a single integer, the first method with + the given number of parameters is returned instead. + at end defun + +The obtained constructor can be passed as an argument to + at code{JAVA:JNEW}, together with any arguments. @code{JAVA:JNEW} can +also be invoked with a string naming the class as its first argument. + + at defun jnew (constructor &rest args) + Creates a new Java object by invoking @var{CONSTRUCTOR} with arguments + @var{ARGS}. @var{CONSTRUCTOR} can be a constructor reference or a + string naming a class. + at end defun + + + at node Accessing Java object and class fields + at subsection Accessing Java object and class fields + +Fields in Java objects can be accessed using the getter and setter +functions @code{JAVA:JFIELD} and @code{(SETF JAVA:JFIELD)}. Static +(class) fields are accessed the same way, but with a class object or +string naming a class as first argument. + +Like @code{JAVA:JCALL} and friends, values returned from these accessors +carry an intended class around, and values which can be converted to +Lisp values will be converted. + + at defun jfield (class-ref-or-field field-or-instance @ + &optional instance value) + + Retrieves or modifies a field in a Java class or instance. + + Supported argument patterns: + + @table @code + + @item class-ref field-name + Retrieve the value of static field @var{field-name} of class + @var{class-ref}. + + @item class-ref field-name instance-ref + Retrieves the value of a class field of the instance. + + @item class-ref field-name primitive-value: + Stores @var{primitive-value} in static field @var{field-name}. + + @item class-ref field-name instance-ref value + Stores @var{value} in a class field of the instance. + + @item class-ref field-name nil value + Stores value in a static field (when value may be confused with an + instance-ref). + + @item field-name instance + Retrieves the value of a field of the instance. The class is derived + from the instance. + + @item field-name instance value + Stores value in a field of the instance. The class is derived from the + instance. + @end table + at end defun + + + at node Calling Java Methods + at subsection Calling Java Methods + +Methods on a java object method in the low-level (basic) API can be +called in two ways: + + at itemize + at item +Calling a specific method reference (which was previously acquired) + + at item +Dynamic dispatch using the method name and the call-specific arguments +provided by finding the best match (@pxref{Parameter matching for FFI dynamic dispatch}). + at end itemize + + at defun jmethod (class-ref method-name &rest parameter-class-refs) + Returns a reference to the Java method @var{method-name} of + @var{class-ref} accepting the given @var{parameter-class-refs}. If + @var{parameter-class-refs} is a single integer, the first method with + the given number of parameters is returned instead. + + The function @code{java:jmethod} is used to acquire a specific method + reference. Its first argument is a Java class designator (a + @code{java:java-class} object returned by @code{java:jclass} or a + string naming a Java class). The second argument is a string naming + the method. + + Any arguments beyond the first two should be strings naming Java + classes, with one exception as listed in the next paragraph. These + classes specify the types of the arguments for the method. + + When @code{java:jmethod} is called with three parameters and the last + parameter is an integer, the first method by that name and matching + number of parameters is returned. + at end defun + +Once a method reference has been acquired, it can be invoked using + at code{java:jcall}, which takes the method as the first argument. The +second argument is the object instance to call the method on, or + at code{NIL} in case of a static method. Any remaining parameters are +used as the remaining arguments for the call. + + at defun jcall (method instance &rest args) + at defunx jcall-raw (method instance &rest args) + Invokes the Java method @var{method} on @var{instance} with arguments + @var{args}. @var{Method} can be a method reference acquired via + @code{jmethod} or a string naming a method. The @code{-raw} version + does not attempt to coerce the arguments or result into a Lisp object. + at end defun + + + at node Calling Java Static Methods + at subsection Calling Java Static Methods + +Like non-static methods, references to static (class) methods can be +acquired by using the @code{java:jmethod} primitive. Static methods are +called with @code{java:jstatic} instead of @code{java:jcall}. + + at defun jstatic (method class &rest args) + at defunx jstatic-raw (method class &rest args) + Invoke the static method @var{method} on class @var{class} with + @var{args}. The @code{-raw} version does not attempt to coerce the + arguments or result into a Lisp object. + at end defun + +Like @code{java:jcall}, @code{java:jstatic} supports dynamic dispatch by +passing the name of the method as a string instead of passing a method +reference. The parameter values should be values to pass in the +function call instead of a specification of classes for each parameter. + + + at node Parameter matching for FFI dynamic dispatch + at subsection Parameter matching for FFI dynamic dispatch + +The algorithm used to resolve the best matching method given the name +and the arguments' types is the same as described in the Java Language +Specification. Any deviation should be reported as a bug. + + at c % ###TODO reference to correct JLS section + + + at menu +* Dynamic dispatch Caveats:: + at end menu + + at node Dynamic dispatch Caveats + at subsubsection Dynamic dispatch: Caveats + +Dynamic dispatch, i.e., invoking a Java method via method name instead +of method reference, is performed by using the Java reflection API. +Generally the dispatch works fine, but there are corner cases where the +API does not correctly reflect all the details involved in calling a +Java method. An example is the following Java code: + + at example +ZipFile jar = new ZipFile("/path/to/some.jar"); +Object els = jar.entries(); +Method method = els.getClass().getMethod("hasMoreElements"); +method.invoke(els); + at end example + +Even though the method @code{hasMoreElements()} is public in + at code{Enumeration}, the above code fails with + + at example +java.lang.IllegalAccessException: Class ... can +not access a member of class java.util.zip.ZipFile\$2 with modifiers +"public" + at sun.reflect.Reflection.ensureMemberAccess(Reflection.java:65) + at java.lang.reflect.Method.invoke(Method.java:583) + at ... + at end example + +This is because the method has been overridden by a non-public class and +the reflection API, unlike @code{javac}, is not able to handle such a case. + +While code like that is uncommon in Java, it is typical of ABCL's FFI +calls. The code above corresponds to the following Lisp code: + + at lisp +(let* ((jar (jnew "java.util.zip.ZipFile" "/path/to/some.jar")) + (els (jcall "entries" jar))) + (jcall "hasMoreElements" els)) + at end lisp + + at noindent +except that the dynamic dispatch part is not shown. + +To avoid such pitfalls, all Java objects in ABCL carry an extra field +representing the ``intended class'' of the object. That class is used +first by @code{JAVA:JCALL} and similar to resolve methods; the actual +class of the object is only tried if the method is not found in the +intended class. Of course, the intended class is always a super-class of +the actual class -- in the worst case, they coincide. The intended class +is deduced by the return type of the method that originally returned the +Java object; in the case above, the intended class of @code{ELS} is + at code{java.util.Enumeration} because that is the return type of the + at code{entries} method. + +While this strategy is generally effective, there are cases where the +intended class becomes too broad to be useful. The typical example +is the extraction of an element from a collection, since methods in +the collection API erase all types to @code{Object}. The user can +always force a more specific intended class by using the @code{JAVA:JCOERCE} +operator. + + at c % \begin{itemize} + at c % \item Java values are accessible as objects of type JAVA:JAVA-OBJECT. + at c % \item The Java FFI presents a Lisp package (JAVA) with many useful + at c % symbols for manipulating the artifacts of expectation on the JVM, + at c % including creation of new objects \ref{JAVA:JNEW}, \ref{JAVA:JMETHOD}), the + at c % introspection of values \ref{JAVA:JFIELD}, the execution of methods + at c % (\ref{JAVA:JCALL}, \ref{JAVA:JCALL-RAW}, \ref{JAVA:JSTATIC}) + at c % \item The JSS package (\ref{JSS}) in contrib introduces a convenient macro + at c % syntax \ref{JSS:SHARPSIGN_DOUBLEQUOTE_MACRO} for accessing Java + at c % methods, and additional convenience functions. + at c % \item Java classes and libraries may be dynamically added to the + at c % classpath at runtime (JAVA:ADD-TO-CLASSPATH). + at c % \end{itemize} + + + at node Implementating Java interfaces in Lisp + at subsection Implementating Java interfaces in Lisp + +ABCL can use the Java reflection-based proxy feature to implement Java +interfaces in Lisp. It has several built-in ways to implement an +interface, and supports definition of new ones. The + at code{JAVA:JMAKE-PROXY} generic function is used to make such +proxies. + + at deffn {Generic Function} jmake-proxy interface implementation @ + &optional lisp-this + + Returns a proxy Java object implementing the provided interface(s) + using methods implemented in Lisp - typically closures, but + implementations are free to provide other mechanisms. + + @code{interface} is a Java interface metaobject (e.g. obtained by + invoking @code{jclass}), or a string naming a Java interface. + @code{implementation} is the object used to implement the interface -- + several built-in methods of jmake-proxy exist for various types of + implementations. @code{lisp-this} is an object passed as first + argument to the functions implementing the Lisp ``methods'' of the + interface, and defaults to @code{NIL}. + + The @var{implementation} argument can be of type: + + @table @code + @item function + The given function will be called with two or more arguments (method + name, @var{lisp-this}, method arguments if applicable) upon any method + invocation on the proxy object. Useful for interfaces with a single + method, or to implement custom interface-implementation strategies. + + @item hash-table + + The Java interface method names are used as keys in the given hash + table to obtain the functions implementing them. Functions will be + called with one or more arguments (@var{lisp-this}, method arguments + if applicable). + + @item package + The Java interface method names are mapped to symbols in + @code{package}. A method called @code{javaMethodName} is mapped to a + Lisp symbol @code{JAVA-METHOD-NAME}. An error is signaled if no such + symbol exists in the package, or if the symbol exists but does not + name a function. Functions will be called with one or more arguments + (@var{lisp-this}, method arguments if applicable). + + @end table + at end deffn + +The returned proxy is an instance of the interface, with methods +implemented with Lisp functions, and can be passed to Java methods +expecting an instance of the given interface. + + + at node Implementation of Java classes in Lisp + at subsection Implementation of Java classes in Lisp + + at defun jnew-runtime-class (class-name &rest args @ + &key (superclass @code{java.lang.Object}) interfaces @ + constructors methods fields (access-flags @code{'(public)}) @ + annotations) + + Creates and loads a Java class with methods calling Lisp closures as + given in @var{methods}. @var{class-name} and @var{super-name} are + strings, @var{interfaces} is a list of strings, @var{constructors}, + @var{methods} and @var{fields} are lists of constructor, method and + field definitions, respectively. + + Constructor definitions - currently NOT supported - are lists of the + form @code{(argument-types function &optional + super-invocation-arguments)} where @var{argument-types} is a list of + strings and @var{function} is a lisp function of @code{(1+ (length + argument-types))} arguments; the instance (@code{this}) is passed in + as the last argument. The optional @var{super-invocation-arguments} is + a list of numbers between 1 and @code{(length argument-types)}, where + the number @var{k} stands for the @var{k}th argument to the just + defined constructor. If present, the constructor of the superclass + will be called with the appropriate arguments. E.g., if the + constructor definition is @code{(("java.lang.String" "int") #'(lambda + (string i this) ...) (2 1))} then the constructor of the superclass + with argument types @code{(int, java.lang.String)} will be called with + the second and first arguments. + + Method definitions are lists of the form @code{(method-name + return-type argument-types function &key modifiers annotations)} where + @var{method-name} is a string, @var{return-type} and + @var{argument-types} are strings or keywords for primitive types + (@code{:void}, @code{:int}, etc.), and @var{function} is a Lisp + function of minimum arity @code{(1+ (length argument-types))}; the + instance (@code{this}) is passed in as the first argument. + + Field definitions are lists of the form @code{(field-name type &key + modifiers annotations)}. + at end defun + + + at node Calling from Java to Lisp + at section Calling from Java to Lisp + +This section describes the various ways that one interacts with Lisp +from Java code. In order to access the Lisp world from Java, one needs +to be aware of a few things, the most important ones being listed below: + + at itemize + at item +All Lisp values are descendants of @code{LispObject}. + + at item +Lisp symbols are accessible either via static members of the + at code{Symbol} class, or by dynamically introspecting a @code{Package} +object. + + at item +The Lisp dynamic environment may be saved via + at code{LispThread.bindSpecial(Binding)} and restored via + at code{LispThread.resetSpecialBindings(Mark)}. + + at item +Functions can be executed by invoking @code{LispObject.execute(args + [...])} + + at end itemize + + + at menu +* Acquiring an Interpreter Object:: +* Evaluating Lisp Forms:: +* Calling Common Lisp Functions Directly:: +* Introspecting a Lisp Object:: + at end menu + + at node Acquiring an Interpreter Object + at subsection Acquiring an Interpreter Object + +The entire ABCL Lisp system resides in the + at code{org.armedbear.lisp} package, but the following code snippets do +not show the relevant import statements in the interest of brevity. An +example of the import statement would be + at example +import org.armedbear.lisp.*; + at end example +to potentially import all the JVM symbol from the + at code{org.armedbear.lisp} namespace. + +There can only ever be a single Lisp interpreter per JVM instance. A +reference to this interpreter is obtained by calling the static method + at code{Interpreter.createInstance()}. + + at example +Interpreter interpreter = Interpreter.createInstance(); + at end example + +If this method has already been invoked in the lifetime of the current +Java process it will return @code{null}, so if you are writing Java +whose life-cycle is a bit out of your control (like in a Java servlet), +a safer invocation pattern might be: + + at example +Interpreter interpreter = Interpreter.getInstance(); +if (interpreter == null) @{ + interpreter = Interpreter.createInstance(); +@} + at end example + + + at node Evaluating Lisp Forms + at subsection Evaluating Lisp Forms + +The Lisp @code{eval} primitive may simply be passed strings for +evaluation: + + at example +String line = "(load \"file.lisp\")"; +LispObject result = interpreter.eval(line); + at end example + +Notice that all possible return values from an arbitrary Lisp +computation are collapsed into a single return value. Doing useful +further computation on the @code{LispObject} depends on knowing what the +result of the computation might be. This usually involves some amount +of @code{instanceof} introspection, and forms a whole topic to itself +(@pxref{Introspecting a Lisp Object}). + +Using @code{eval} involves the Lisp interpreter. Lisp functions may +also be directly invoked by Java method calls as follows. One simply +locates the package containing the symbol, obtains a reference to the +symbol, and then invokes the @code{execute()} method with the desired +parameters. + + at example +interpreter.eval("(defun foo (msg)" + + "(format nil \"You told me '~A'~%\" msg))"); +Package pkg = Packages.findPackage("CL-USER"); +Symbol foo = pkg.findAccessibleSymbol("FOO"); +Function fooFunction = (Function)foo.getSymbolFunction(); +JavaObject parameter = new JavaObject("Lisp is fun!"); +LispObject result = fooFunction.execute(parameter); +// How to get the "naked string value"? +System.out.println("The result was " + result.writeToString()); + at end example + + + at node Calling Common Lisp Functions Directly + at subsection Calling Common Lisp Functions Directly + +If one is calling a function in the @var{CL} package, the syntax can +become considerably simpler. If we can locate the instance of +definition in the ABCL Java source, we can invoke the symbol directly. +For instance, to tell if a @code{LispObject} is (Lisp) @code{NIL}, we +can invoke the CL function @code{NULL} in the following way: + + at example +boolean nullp(LispObject object) @{ + LispObject result = Primitives.NULL.execute(object); + if (result == NIL) @{ // the symbol 'NIL' is explicitly named in the Java + // namespace at ``Symbol.NIL'' + // but is always present in the + // local namespace in its unadorned form for + // the convenience of the User. + return false; + @} + return true; +@} + at end example + + + at node Introspecting a Lisp Object + at subsection Introspecting a Lisp Object + +We present various patterns for introspecting an arbitrary + at code{LispObject} which can hold the result of every Lisp evaluation +into semantics that Java can meaningfully deal with. + + + at menu +* LispObject as boolean:: +* LispObject as a list:: + at end menu + + at node LispObject as boolean + at subsubsection LispObject as @code{boolean} + +If the @code{LispObject} is to be interpreted as a generalized boolean +value, one can use @code{getBooleanValue()} to convert to Java: + + at example +LispObject object = Symbol.NIL; +boolean javaValue = object.getBooleanValue(); + at end example + +Since in Lisp any value other than @code{NIL} means "true", Java +equality can also be used, which is a bit easier to type and better in +terms of information it conveys to the compiler: + + at example +boolean javaValue = (object != Symbol.NIL); + at end example + + + at node LispObject as a list + at subsubsection LispObject as a list + +If @code{LispObject} is a list, it will have the Java type @code{Cons}. +One can then use the @code{copyToArray} method to make things a bit more +suitable for Java iteration. + + at example +LispObject result = interpreter.eval("'(1 2 4 5)"); +if (result instanceof Cons) @{ + LispObject array[] = ((Cons)result.copyToArray()); + ... +@} + at end example + +A more Lispy way to iterate down a list is to use the @code{cdr()} +access function just as like one would traverse a list in Lisp:; + + at example +LispObject result = interpreter.eval("'(1 2 4 5)"); +while (result != Symbol.NIL) @{ + doSomething(result.car()); + result = result.cdr(); +@} + at end example + + + at node Java Scripting API (JSR-223) + at section Java Scripting API (JSR-223) + +ABCL can be built with support for JSR-223, which offers a +language-agnostic API to invoke other languages from Java. The binary +distribution from ABCL's homepage is built with JSR-223 support. If you +are building ABCL from source on a pre-1.6 JVM, you need to have a +JSR-223 implementation in your classpath (such as Apache Commons BSF 3.x +or greater) in order to build ABCL with JSR-223 support; otherwise, this +feature will not be built. + +This section describes the design decisions behind the ABCL JSR-223 +support. It is not a description of what JSR-223 is or a tutorial on how +to use it. See + at url{http://trac.common-lisp.net/armedbear/browser/trunk/abcl/examples/jsr-223} +for example usage. + + + at menu +* Conversions:: +* Implemented JSR-223 interfaces:: +* Start-up and configuration file:: +* Evaluation:: +* Compilation:: +* Invocation of functions and methods:: +* Creating Lisp interface proxies:: + at end menu + + at node Conversions + at subsection Conversions + +In general, ABCL's implementation of the JSR-223 API performs implicit +conversion from Java objects to Lisp objects when invoking Lisp from +Java, and the opposite when returning values from Java to Lisp. This +potentially reduces coupling between user code and ABCL. To avoid such +conversions, wrap the relevant objects in @code{JavaObject} instances. + + + at node Implemented JSR-223 interfaces + at subsection Implemented JSR-223 interfaces + +JSR-223 defines three main interfaces, of which two (@code{Invocable} +and @code{Compilable}) are optional. ABCL implements all three +interfaces - @code{ScriptEngine} and the two optional ones - almost +completely. While the JSR-223 API is not specific to a single scripting +language, it was designed with languages with a more or less Java-like +object model in mind: languages such as Javascript, Python, Ruby, which +have a concept of "class" or "object" with "fields" and "methods". Lisp +is a bit different, so certain adaptations were made, and in one case a +method has been left unimplemented since it does not map at all to Lisp. + + + at menu +* The ScriptEngine object:: + at end menu + + at node The ScriptEngine object + at subsubsection The ScriptEngine object + +The main interface defined by JSR-223, @code{javax.script.ScriptEngine}, +is implemented by the class + at code{org.armedbear.lisp.scripting.AbclScriptEngine}. @code{AbclScriptEngine} +is a singleton, reflecting the fact that ABCL is a singleton as +well. You can obtain an instance of @code{AbclScriptEngine} using + at code{AbclScriptEngineFactory} or by using the service provider +mechanism through @code{ScriptEngineManager} (refer to the + at code{javax.script} documentation). + + + at node Start-up and configuration file + at subsection Start-up and configuration file + +At start-up (i.e. when its constructor is invoked, as part of the static +initialization phase of @code{AbclScriptEngineFactory}), the ABCL script +engine attempts to load an "init file" from the classpath +(@file{/abcl-script-config.lisp}). If present, this file can be used to +customize the behavior of the engine, by setting a number of variables +in the @code{ABCL-SCRIPT} package. Here is a list of the available +variables: + + at defvar @earmuffs{use-throwing-debugger} +controls whether ABCL uses a non-standard debugging hook function to +throw a Java exception instead of dropping into the debugger in case of +unhandled error conditions. + +Its default value is @code{T}, since it is more convenient for Java +programmers using Lisp as a scripting language to have it return +exceptions to Java instead of handling them in the Lisp world. + +Known issues: the non-standard debugger hook has been reported to +misbehave in certain circumstances, so consider disabling it if it +doesn't work for you. + at end defvar + + at defvar @earmuffs{launch-swank-at-startup} +If true, Swank will be launched at startup. See @code{*swank-dir*} and + at code{*swank-port*}. Default value: @code{NIL}. + at end defvar + + at defvar @earmuffs{swank-dir} +The directory where Swank is installed. Must be set if + at code{*launch-swank-at-startup*} is true. + at end defvar + + at defvar @earmuffs{swank-port} +The port where Swank will listen for connections. Must be set if + at code{*launch-swank-at-startup*} is true. Default value: 4005 + at end defvar + +Additionally, at startup the @code{AbclScriptEngine} will execute + at code{(require 'asdf)} - in fact, it uses asdf to load Swank. + + + at node Evaluation + at subsection Evaluation + +Code is read and evaluated in the package @code{ABCL-SCRIPT-USER}. This +package uses the @code{COMMON-LISP}, @code{JAVA} and @code{ABCL-SCRIPT} +packages. Future versions of the script engine might make thisf default +package configurable. The @code{CL:LOAD} function is used under the hood +for evaluating code, and thus the behavior of @code{LOAD} is +guaranteed. This allows, among other things, @code{IN-PACKAGE} forms to +change the package in which the loaded code is read. + +It is possible to evaluate code in what JSR-223 calls a +``ScriptContext'' (basically a flat environment of name-to-value +pairs). This context is used to establish special bindings for all the +variables defined in it; since variable names are strings from Java's +point of view, they are first interned using @code{READ-FROM-STRING} +with, as usual, @code{ABCL-SCRIPT-USER} as the default +package. Variables are declared special because CL's @code{LOAD}, + at code{EVAL} and @code{COMPILE} functions work in a null lexical +environment and would ignore non-special bindings. + +Contrary to what the function @code{LOAD} does, evaluation of a series +of forms returns the value of the last form instead of @code{T}, so the +evaluation of short scripts does the Right Thing. + + + at node Compilation + at subsection Compilation + + at code{AbclScriptEngine} implements the @code{javax.script.Compilable} +interface. Currently it only supports compilation using temporary +files. Compiled code, returned as an instance of + at code{javax.script.CompiledScript}, is read, compiled and executed by +default in the @code{ABCL-SCRIPT-USER} package, just like evaluated +code. In contrast to evaluated code, though, due to the way the ABCL +compiler works, compiled code contains no reference to top-level +self-evaluating objects (like numbers or strings). Thus, when evaluated, +a piece of compiled code will return the value of the last +non-self-evaluating form: for example the code @code{(do-something) 42} +will return 42 when interpreted, but will return the result of + at code{(do-something)} when compiled and later executed. To ensure +consistency of behavior between interpreted and compiled code, make sure +the last form is always a compound form -- at least @code{(identity +some-literal-object)}. Note that this issue should not matter in real +code, where it is unlikely a top-level self-evaluating form will appear +as the last form in a file (in fact, the Common Lisp load function +always returns @code{T} upon success; with JSR-223 this policy has +been changed to make evaluation of small code snippets work as +intended). + + + at node Invocation of functions and methods + at subsection Invocation of functions and methods + + at code{AbclScriptEngine} implements the @code{javax.script.Invocable} +interface, which allows to directly call Lisp functions and methods, and +to obtain Lisp implementations of Java interfaces. This is only +partially possible with Lisp since it has functions, but not methods -- +not in the traditional OO sense, at least, since Lisp methods belong to +generic functions. Thus, the method @code{invokeMethod()} is not +implemented and throws an @code{UnsupportedOperationException} when +called. The @code{invokeFunction()} method is used to call both regular +and generic functions. + + + at node Creating Lisp interface proxies + at subsection Creating Lisp interface proxies + +The functionality of @code{jmake-proxy} is exposed by the class + at code{AbclScriptEngine} via the two methods @code{getInterface(Class)} +and @code{getInterface(Object, Class)}. The former returns an interface +implemented with the current Lisp package, the latter allows the +programmer to pass an interface-implementation object which will in turn +be passed to the @code{jmake-proxy} generic function. + + + + + at node Implementation Dependent Extensions + at chapter Implementation Dependent Extensions + +As outlined by the CLHS ANSI conformance guidelines, we document the +extensions to the Armed Bear Lisp implementation made accessible to the +user by virtue of being an exported symbol in the @code{JAVA}, + at code{THREADS}, or @code{EXTENSIONS} packages. + + + at menu +* Extensions in the JAVA package:: +* Extensions in the THREADS package:: +* Extensions in the EXT package:: + at end menu + + at node Extensions in the JAVA package + at section Extensions in the JAVA package + + at c % include autogen docs for the JAVA package. + at c \include{java} + + at node Extensions in the THREADS package + at section Extensions in the THREADS package + +The extensions for handling multithreaded execution are collected in +the @code{THREADS} package. Most of the abstractions in Doug Lea's +excellent @code{java.util.concurrent} packages may be manipulated +directly via the JSS contrib to great effect. + + at c % include autogen docs for the THREADS package. + at c \include{threads} + + at node Extensions in the EXT package + at section Extensions in the EXT package + +The symbols in the @code{EXTENSIONS} package (nicknamed @code{EXT}) +constitutes extensions to the ANSI standard that are +potentially useful to the user. They include functions for manipulating +network sockets, running external programs, registering object +finalizers, constructing reference weakly held by the garbage collector +and others. + +For a generic function interface to the native JVM contract for + at code{java.util.List}, @pxref{Extensible Sequences}. + + at c % include autogen docs for the EXTENSIONS package. + at c \include{extensions} + + at node Beyond ANSI + at chapter Beyond ANSI + +Naturally, in striving to be a useful contemporary Common Lisp +implementation, ABCL endeavors to include extensions beyond the ANSI +specification which are either widely adopted or are especially useful +in working with the hosting JVM. + + at menu +* Modifying the JVM Classpath:: +* Compiler to Java 5 Bytecode:: +* Pathnames:: +* Extensible Sequences:: +* Extensions to CLOS:: +* Extensions to the Reader:: +* Overloading of the REQUIRE Mechanism:: +* JSS optionally extends the Reader:: +* ASDF:: + at end menu + + at node Modifying the JVM Classpath + at section Modifying the JVM Classpath + + at deffn {Generic Function} add-to-classpath jar-or-jars @ + &optional classloader + + The @code{add-to-classpath} generic functions allows one to add a + pathname or list of pathnames to the current classpath used by ABCL, + allowing the dynamic loading of JVM objects: + + at lisp +(add-to-classpath "/path/to/some.jar") + at end lisp + + N.b @code{add-to-classpath} only affects the classloader used by ABCL + (the value of the special variable @code{java::*classloader*}). It has + no effect on Java code outside ABCL. + at end deffn + + at node Compiler to Java 5 Bytecode + at section Compiler to Java 5 Bytecode + +The @code{CL:COMPILE-FILE} interface emits a packed fasl format whose +Pathname has the type @file{abcl}. These fasls are operating system +neutral byte archives packaged by the zip compression format which +contain artifacts that are understood by @code{CL:LOAD}. + + at node Pathnames + at section Pathnames + +We implement an extension to the @code{CL:PATHNAME} that allows for the +description and retrieval of resources named in a URI at footnote{A +URI is essentially a superset of what is commonly understood as a +URL. We sometimes use the term URL as shorthand in describing the +URL Pathnames, even though the corresponding encoding is more akin to a +URI as described in RFC3986.} scheme that the JVM ``understands''. By +definition, support is built-in into the JVM to access the + at code{http://} and @code{https://} schemes but additional protocol +handlers may be installed at runtime by having JVM symbols present +in the @code{sun.net.protocol.dynamic} package (see + at url{http://java.sun.com/developer/onlineTraining/protocolhandlers/} for +more details). + +ABCL has created specializations of the ANSI @code{PATHNAME} object to +enable to use of URIs to address dynamically loaded resources for +the JVM. The @code{EXT:URL-PATHNAME} specialization has a corresponding +URI whose canonical representation is defined to be the + at code{NAMESTRING} of the Pathname. The @code{EXT:JAR-PATHNAME} extension +further specializes the the @code{EXT:URL-PATHNAME} to provide access to +components of zip and jar archives. + + at c % RDF description of type hierarchy + at c % TODO Render via some LaTeX mode for graphviz? + at example +@@prefix ext: . +@@prefix cl: . + + a . + a . + a . + at end example + + at deftp {Built-In Class} url-pathname + at deftpx {Built-In Class} jar-pathname + + @code{url-pathname} and @code{jar-pathname} are subclasses of the + @code{pathname} built-in class. Objects of type + @code{Ext:url-pathname} and @code{ext:jar-pathname} may be used + anywhere a @code{cl:pathname} is accepted with the following caveats: + + at itemize + at item +A stream obtained via @code{cl:open} on a @code{ext:url-pathname} cannot +be the target of write operations. + + at item +Any results of canonicalization procesures performed on the underlying +URI are discarded between resolutions (i.e. the implementation does not +attempt to cache the results of current name resolution of the +representing resource unless it is requested to be resolved). Upon +resolution, any canoicalization procedures followed in resolving the +resource (e.g., following redirects) are discarded. Users may +programatically initiate a new, local computation by applying the + at code{cl:truename} function to a @code{ext:url-pathname} object. +Depending on the reliablity and properties of your local REST +infrastructure, these results may not necessarily be idempotent over +time. at footnote {See + at url{http://code.google.com/p/abcl-dynamic-install/source/browse/doc/design/pathnames/pathnames.tex} +for the draft of the publication of the technical details} + at end itemize + + at end deftp + +The implementation of @code{ext:url-pathname} allows the ABCL user to +dynamically load code from the network. For example, Quicklisp may be +completely installed from the REPL as the single form: + + at lisp +CL-USER> (load "http://beta.quicklisp.org/quicklisp.lisp") + at end lisp + +The implementation currently breaks ANSI conformance by allowing the +types able to be @code{cl:read} for the @var{device} to return a +possible @code{cons} of @code{cl:pathname} objects. + at c %% citation from CLHS needed. + +In order to ``smooth over'' the bit about types being @code{cl:read} from + at code{cl:pathname} components, we extend the semantics for the usual PATHNAME +merge semantics when @code{*default-pathname-defaults*} contains a + at code{ext:jar-pathname}. + + at menu +* Implementation of Pathname Extensions:: + at end menu + + at node Implementation of Pathname Extensions + at subsection Implementation of Pathname Extensions + +The implementation of these extensions stores all the additional +information in the @code{CL:PATHNAME} object itself in ways that while +strictly speaking are conformant, nonetheless may trip up libraries that +don't expect the following: + + at itemize + at item + at code{DEVICE} can be either a string denoting a drive letter under DOS, +or a list of exactly one or two elements. If @code{DEVICE} is a list, +it denotes a @code{EXT:JAR-PATHNAME}, with the entries containing + at code{CL:PATHNAME} objects which describe the outer and (possibly inner) +locations of the jar archive. at footnote{The case of inner and outer + at code{EXT:EJAR-PATHNAME} arises when zip archives themselves contain zip +archives, which is the case when the ABCL fasl is included in the + at file{abcl.jar} zip archive.} + + at item +An @code{EXT:URL-PATHNAME} always has a @code{HOST} component that is a +property list. The values of the @code{HOST} property list are always +character strings. The allowed keys have the following meanings: + + at table @code + + at item :SCHEME +Scheme of URI ("http", "ftp", "bundle", etc.) + + at item :AUTHORITY +Valid authority according to the URI scheme. For "http" this could be +"example.org:8080". + + at item :QUERY +The query portion of the URI + + at item :FRAGMENT +The fragment portion of the URI + at end table + at end itemize + +In order to encapsulate the implementation decisions for these meanings, +the following functions provide a @code{setf}-able API for reading and writing +such values. + + at deffn {Accessor} url-pathname-scheme + at deffnx {Accessor} url-pathname-fragment + at deffnx {Accessor} url-pathname-authority + at deffnx {Accessor} url-pathname-query + These functions and their @code{setf} form provide read and write + access to the components of a @code{url-pathname} object. + at end deffn + +The specific subtype of a Pathname may be determined with the predicates + at code{pathname-url-p} and @code{pathname-jar-p}. + + at defun pathname-url-p object + at defunx pathname-jar-p object + These predicates return @code{T} if @var{object} is a designator for a + pathname of the specific type. E.g.: + at lisp +(pathname-url-p "http://google.com/") + at result{} T + at end lisp + at end defun + + + at node Extensible Sequences + at section Extensible Sequences + +See + at url{http://doc.gold.ac.uk/~mas01cr/papers/ilc2007/sequences-20070301.pdf} +for the design. + +The @code{SEQUENCE} package fully implements Christophe Rhodes' proposal +for extensible sequences. These user extensible sequences are used +directly in @code{java-collections.lisp} to provide these CLOS abstractions +on the standard Java collection classes as defined by the + at code{java.util.List} contract. + + at c %% an Example of using java.util.Lisp in Lisp would be nice + +This extension is not automatically loaded by the implementation. It +may be loaded via: + + at lisp +CL-USER> (require 'java-collections) + at end lisp + +if both extensible sequences and their application to Java collections +is required, or + + at lisp +CL-USER> (require 'extensible-sequences) + at end lisp + +if only the extensible sequences API is required. + +Note that @code{(require 'java-collections)} must be issued before + at code{java.util.List} or any subclass is used as a specializer in a CLOS +method definition (see the section below). + + at node Extensions to CLOS + at section Extensions to CLOS + + at menu +* Metaobject Protocol:: +* Specializing on Java classes:: + at end menu + + at node Metaobject Protocol + at subsection Metaobject Protocol + +ABCL implements the metaobject protocol for CLOS as specified in AMOP. +The symbols are exported from the package @code{MOP}. + + at node Specializing on Java classes + at subsection Specializing on Java classes + +There is an additional syntax for specializing the parameter of a +generic function on a java class, viz. @code{(java:jclass CLASS-STRING)} +where @code{CLASS-STRING} is a string naming a Java class in dotted package +form. + +For instance, the following specialization would perhaps allow one to +print more information about the contents of a + at code{java.util.Collection} object: + + at lisp +(defmethod print-object ((coll (java:jclass "java.util.Collection")) + stream) + ;;; ... +) + at end lisp + +If the class had been loaded via a classloader other than the original +the class you wish to specialize on, one needs to specify the +classloader as an optional third argument. + + at lisp +(defparameter *other-classloader* + (jcall "getBaseLoader" cl-user::*classpath-manager*)) + +(defmethod print-object + ((device-id (java:jclass "dto.nbi.service.hdm.alcatel.com.NBIDeviceID" + *other-classloader*)) + stream) + ;;; ... +) + at end lisp + + at node Extensions to the Reader + at section Extensions to the Reader + +We implement a special hexadecimal escape sequence for specifying 32-bit +characters to the Lisp reader, at footnote{This represents a compromise +with contemporary in 2011 32bit hosting architecures for which we wish +to make text processing efficient. Should the User require more control +over UNICODE processing we recommend Edi Weiz's excellent work with +FLEXI-STREAMS which we fully support} namely we allow a sequences of the +form @code{#\Uxxxx} to be processed by the reader as character whose +code is specified by the hexadecimal digits @code{xxxx}. The +hexadecimal sequence may be one to four digits long. + +Note that this sequence is never output by the implementation. Instead, +the corresponding Unicode character is output for characters whose +code is greater than @code{0x00ff}. + + at node Overloading of the REQUIRE Mechanism + at section Overloading of the CL:REQUIRE Mechanism + +The @code{CL:REQUIRE} mechanism is overloaded by attaching the following +semantic to the execution of @code{REQUIRE} on the following symbols: + + at table @code + at item ASDF + +Loads the ASDF implementation shipped with ABCL. After ASDF has been +loaded in this manner, symbols passed to @code{CL:REQUIRE} which are +otherwise unresolved are passed to ASDF for a chance for resolution. +This means, for instance, if @code{CL-PPCRE} can be located as a loadable +ASDF system, @code{(require 'cl-ppcre)} is equivalent to + at code{(asdf:load-system 'cl-ppcre)}. + + at item ABCL-CONTRIB +Locates and pushes the toplevel contents of @file{abcl-contrib.jar} into +the ASDF central registry, namely: + + @table @code + @item abcl-asdf + Functions for loading JVM artifacts dynamically, hooking into ASDF + objects where possible. @xref{abcl-asdf}. + + @item asdf-jar + Package addressable JVM artifacts via @code{abcl-asdf} descriptions + as a single binary artifact including recursive dependencies. + + @item mvn + + These systems name common JVM artifacts from the distributed pom.xml + graph of Maven Aether, at the moment @code{jna} dynamically loads + @code{jna.jar} version 3.5.1 from the network. at footnote{This loading + can be inhibited if, at runtime, the Java class corresponding + @code{:classname} clause of the system definition is present.} + + @end table + + at end table + + at defvar @earmuffs{module-provider-functions} + The user may extend the @code{cl:require} mechanism by pushing + function hooks onto this variable. Each such hook function must take + a single argument containing the symbol passed to @code{cl:require} + and return a non- at code{NIL} value if it successfully resolved the + symbol. + at end defvar + + at node JSS optionally extends the Reader + at section JSS optionally extends the Reader + +The JSS contrib consitutes an additional, optional extension to the +reader in the definition of the @code{SHARPSIGN-DOUBLE-QUOTE} +(@code{#"}) reader macro. @xref{JSS}. + + at node ASDF + at section ASDF + +ASDF is packaged as a core component of ABCL, but not initialized by +default as it relies on the CLOS subsystem which can take a bit of time +to start. at footnote{While this time is ``merely'' on the order of seconds +for contemporary 2011 machines, for applications that need to initialize +quickly, for example a web server, this time might be unnecessarily +long} The packaged ASDF may be loaded by the ANSI + at code{REQUIRE} mechanism as follows: + + at lisp +CL-USER> (require 'asdf) + at end lisp + + at node Contrib + at chapter Contrib + +The ABCL contrib is packaged as a separate jar archive usually named + at file{abcl-contrib.jar} or possibly something like + at file{abcl-contrib-1.1.0.jar}. The contrib jar is not loaded by the +implementation by default, and must be first intialized by the + at code{REQUIRE} mechanism before using any specific contrib: + + at lisp +CL-USER> (require 'abcl-contrib) + at end lisp + + at menu +* abcl-asdf:: +* asdf-jar:: +* JSS:: +* jfli:: +* asdf-install:: + at end menu + + at node abcl-asdf + at section abcl-asdf + +This contrib enables an additional syntax for ASDF system definition +which dynamically loads JVM artifacts such as @file{jar} archives +via encapsulation of the Maven build tool. The Maven Aether component +can also be directly manipulated by the function associated with the + at code{ABCL-ASDF:RESOLVE-DEPENDENCIES} symbol. + + at c %ABCL specific contributions to ASDF system definition mainly + at c %concerned with finding JVM artifacts such as jar archives to be + at c %dynamically loaded. + +When loaded, abcl-asdf adds the following objects to ASDF: + at code{JAR-FILE}, @code{JAR-DIRECTORY}, @code{CLASS-FILE-DIRECTORY} and + at code{MVN}, exporting them (and others) as public symbols from the + at code{ASDF} package. + + at menu +* Referencing Maven Artifacts via ASDF:: +* The abcl-asdf API:: +* Directly Instructing Maven to Download JVM Artifacts:: + at end menu + + at node Referencing Maven Artifacts via ASDF + at subsection Referencing Maven Artifacts via ASDF + +Maven artifacts may be referenced within ASDF system definitions. The +following example references the @code{log4j-1.4.9.jar} JVM artifact +which provides a widely-used abstraction for handling logging systems: + + at lisp +(in-package :asdf) + +(defsystem :log4j + :components ((:mvn "log4j/log4j" :version "1.4.9"))) + at end lisp + + at node The abcl-asdf API + at subsection The abcl-asdf API + +We define an API for abcl-asdf as consisting of the following +ASDF classes: + + at code{JAR-DIRECTORY}, @code{JAR-FILE}, and @code{CLASS-FILE-DIRECTORY} +for JVM artifacts that have a currently valid pathname representation. + +Both the @code{MVN} and @code{IRI} classes descend from + at code{ASDF-COMPONENT}, but do not directly have a filesystem location. + +For use outside of ASDF system definitions, we currently define one +method, @code{ABCL-ASDF:RESOLVE-DEPENDENCIES} which locates, +downloads, caches, and then loads into the currently executing JVM +process all recursive dependencies annotated in the Maven @file{pom.xml} +graph. + + at node Directly Instructing Maven to Download JVM Artifacts + at subsection Directly Instructing Maven to Download JVM Artifacts + +Bypassing ASDF, one can directly issue requests for the Maven +artifacts to be downloaded: + + at lisp +CL-USER> (abcl-asdf:resolve-dependencies "com.google.gwt" "gwt-user") + at print{} WARNING: Using LATEST for unspecified version. + at print{} "/Users/evenson/.m2/repository/com/google/gwt/gwt-user/2.4.0-rc1 + at print{} /gwt-user-2.4.0-rc1.jar:/Users/evenson/.m2/repository/javax/vali + at print{} dation/validation-api/1.0.0.GA/validation-api-1.0.0.GA.jar:/User + at print{} s/evenson/.m2/repository/javax/validation/validation-api/1.0.0.G + at print{} A/validation-api-1.0.0.GA-sources.jar" + at end lisp + +To actually load the dependency, use the @code{JAVA:ADD-TO-CLASSPATH} +generic function: + + at lisp +CL-USER> (java:add-to-classpath + (abcl-asdf:resolve-dependencies "com.google.gwt" "gwt-user")) + at end lisp + +Notice that all recursive dependencies have been located and installed +locally from the network as well. + + at node asdf-jar + at section asdf-jar + +The asdf-jar contrib provides a system for packaging ASDF systems into +jar archives for ABCL. Given a running ABCL image with loadable ASDF +systems the code in this package will recursively package all the +required source and fasls in a jar archive. + +The documentation for this contrib can be found at + at url{http://svn.common-lisp.net/armedbear/trunk/abcl/contrib/asdf-jar/README.markdown}. + + + at node JSS + at section JSS + +To one used to the more universal syntax of Lisp pairs upon which the +definition of read and compile time macros is quite +natural, at footnote{See Graham's ``On Lisp'' + at url{http://lib.store.yahoo.net/lib/paulgraham/onlisp.pdf}.} the Java +syntax available to the Java programmer may be said to suck. To +alleviate this situation, the JSS contrib introduces the + at code{SHARPSIGN-DOUBLE-QUOTE} (@code{#"}) reader macro, which allows the +specification of the name of invoking function as the first element of +the relevant s-expr which tends to be more congruent to how Lisp +programmers seem to be wired to think. + +While quite useful, we don't expect that the JSS contrib will be the +last experiment in wrangling Java from Common Lisp. + + at menu +* JSS usage:: + at end menu + + at node JSS usage + at subsection JSS usage + +Example: + + at lisp +CL-USER> (require 'abcl-contrib) + at result{} ("ABCL-CONTRIB") +CL-USER> (require 'jss) + at result{} ("JSS") +CL-USER) (#"getProperties" 'java.lang.System) + at result{} # +CL-USER) (#"propertyNames" (#"getProperties" 'java.lang.System)) + at result{} # + at end lisp + +Some more information on jss can be found in its documentation at + at url{http://svn.common-lisp.net/armedbear/trunk/abcl/contrib/jss/README.markdown} + + at node jfli + at section jfli + +This contrib contains a pure-Java version of JFLI. + + at node asdf-install + at section asdf-install + +The asdf-install contrib provides an implementation of ASDF-INSTALL. +This method of installing Lisp libraries is superseded by Quicklisp, +which can be installed via @code{(load +"http://beta.quicklisp.org/quicklisp.lisp")}. + + + at node History + at chapter History + +ABCL was originally the extension language for the J editor, which was +started in 1998 by Peter Graves. Sometime in 2003, a whole lot of code +that had previously not been released publically was suddenly committed +that enabled ABCL to be plausibly termed an emergent ANSI Common Lisp +implementation candidate. + +From 2006 to 2008, Peter manned the development lists, incorporating +patches as made sense. After a suitable search, Peter nominated Erik +H@"ulsmann to take over the project. + +In 2008, the implementation was transferred to the current maintainers, +who have strived to improve its usability as a contemporary Common Lisp +implementation. + +On October 22, 2011, with the publication of this Manual explicitly +stating the conformance of Armed Bear Common Lisp to ANSI, we +released abcl-1.0.0. We released abcl-1.0.1 as a maintainence release +on January 10, 2012. + +In December 2012, we revised the implementation by adding (A)MOP with +the release of abcl-1.1.0. + + at node Concept Index + at appendix Concept Index + + at printindex cp + + at node Function Index + at appendix Function Index + + at printindex fn + + at node Variable Index + at appendix Variable Index + + at printindex vr + + at node Type Index + at appendix Type Index + + at printindex tp + + at node Colophon + at unnumbered Colophon + +This manual is maintained in Texinfo, and automatically translated into +other forms (e.g. HTML or pdf). If you're @emph{reading} this manual in +one of these non-Texinfo translated forms, that's fine, but if you want +to @emph{modify} this manual, you are strongly advised to seek out a +Texinfo version and modify that instead of modifying a translated +version. Even better might be to seek out @emph{the} Texinfo version +(maintained at the time of this writing as part of the ABCL project at + at uref{http://common-lisp.net/project/armedbear/}) and submit a patch. + + at bye From vvoutilainen at common-lisp.net Sun Jan 13 10:29:07 2013 From: vvoutilainen at common-lisp.net (vvoutilainen at common-lisp.net) Date: Sun, 13 Jan 2013 02:29:07 -0800 Subject: [armedbear-cvs] r14351 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Jan 13 02:29:06 2013 New Revision: 14351 Log: Fix 288, add alternative names to name-char for ascii control characters 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 Sun Jan 6 10:19:42 2013 (r14350) +++ trunk/abcl/src/org/armedbear/lisp/LispCharacter.java Sun Jan 13 02:29:06 2013 (r14351) @@ -560,30 +560,25 @@ return i; } catch (NumberFormatException e) {}; } - - if (lower.equals("null")) - return 0; if (lower.equals("nul")) return 0; - if (lower.equals("bell")) + if (lower.equals("bel")) return 7; - if (lower.equals("backspace")) + if (lower.equals("bs")) return '\b'; - if (lower.equals("tab")) + if (lower.equals("ht")) return '\t'; - if (lower.equals("linefeed")) - return '\n'; - if (lower.equals("newline")) + if (lower.equals("linefeed") || lower.equals("lf")) return '\n'; - if (lower.equals("page")) + if (lower.equals("ff")) return '\f'; - if (lower.equals("return")) + if (lower.equals("cr")) return '\r'; - if (lower.equals("escape")) - return 27; - if (lower.equals("space")) + if (lower.equals("esc")) + return 27; + if (lower.equals("space") || lower.equals("sp")) return ' '; - if (lower.equals("rubout")) + if (lower.equals("rubout") || lower.equals("del")) return 127; if (lower.startsWith("u")) { int length = lower.length(); From vvoutilainen at common-lisp.net Sun Jan 13 20:05:51 2013 From: vvoutilainen at common-lisp.net (vvoutilainen at common-lisp.net) Date: Sun, 13 Jan 2013 12:05:51 -0800 Subject: [armedbear-cvs] r14352 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Jan 13 12:05:50 2013 New Revision: 14352 Log: Fix ticket 290, a compilation error of a quoted list Modified: trunk/abcl/src/org/armedbear/lisp/dump-form.lisp Modified: trunk/abcl/src/org/armedbear/lisp/dump-form.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/dump-form.lisp Sun Jan 13 02:29:06 2013 (r14351) +++ trunk/abcl/src/org/armedbear/lisp/dump-form.lisp Sun Jan 13 12:05:50 2013 (r14352) @@ -125,7 +125,7 @@ (declaim (ftype (function (cons stream) t) dump-cons)) (defun dump-cons (object stream) - (cond ((and (eq (car object) 'QUOTE) (= (length object) 2)) + (cond ((and (eq (car object) 'QUOTE) (proper-list-of-length-p object 2)) (%stream-write-char #\' stream) (dump-object (%cadr object) stream)) (t From mevenson at common-lisp.net Mon Jan 14 09:58:30 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 14 Jan 2013 01:58:30 -0800 Subject: [armedbear-cvs] r14353 - branches/1.1.x/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Jan 14 01:58:29 2013 New Revision: 14353 Log: Backport r14351 | vvoutilainen | 2013-01-13 11:29:06 +0100 (Sun, 13 Jan 2013) | 1 line. Fix 288, add alternative names to name-char for ascii control characters. Modified: branches/1.1.x/src/org/armedbear/lisp/LispCharacter.java Modified: branches/1.1.x/src/org/armedbear/lisp/LispCharacter.java ============================================================================== --- branches/1.1.x/src/org/armedbear/lisp/LispCharacter.java Sun Jan 13 12:05:50 2013 (r14352) +++ branches/1.1.x/src/org/armedbear/lisp/LispCharacter.java Mon Jan 14 01:58:29 2013 (r14353) @@ -560,30 +560,25 @@ return i; } catch (NumberFormatException e) {}; } - - if (lower.equals("null")) - return 0; if (lower.equals("nul")) return 0; - if (lower.equals("bell")) + if (lower.equals("bel")) return 7; - if (lower.equals("backspace")) + if (lower.equals("bs")) return '\b'; - if (lower.equals("tab")) + if (lower.equals("ht")) return '\t'; - if (lower.equals("linefeed")) - return '\n'; - if (lower.equals("newline")) + if (lower.equals("linefeed") || lower.equals("lf")) return '\n'; - if (lower.equals("page")) + if (lower.equals("ff")) return '\f'; - if (lower.equals("return")) + if (lower.equals("cr")) return '\r'; - if (lower.equals("escape")) - return 27; - if (lower.equals("space")) + if (lower.equals("esc")) + return 27; + if (lower.equals("space") || lower.equals("sp")) return ' '; - if (lower.equals("rubout")) + if (lower.equals("rubout") || lower.equals("del")) return 127; if (lower.startsWith("u")) { int length = lower.length(); From mevenson at common-lisp.net Mon Jan 14 10:01:03 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 14 Jan 2013 02:01:03 -0800 Subject: [armedbear-cvs] r14354 - branches/1.1.x/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Jan 14 02:01:01 2013 New Revision: 14354 Log: Backport r14352 | vvoutilainen | 2013-01-13 21:05:50 +0100 (Sun, 13 Jan 2013) | 1 line. Fix ticket 290, a compilation error of a quoted list. Modified: branches/1.1.x/src/org/armedbear/lisp/dump-form.lisp Modified: branches/1.1.x/src/org/armedbear/lisp/dump-form.lisp ============================================================================== --- branches/1.1.x/src/org/armedbear/lisp/dump-form.lisp Mon Jan 14 01:58:29 2013 (r14353) +++ branches/1.1.x/src/org/armedbear/lisp/dump-form.lisp Mon Jan 14 02:01:01 2013 (r14354) @@ -125,7 +125,7 @@ (declaim (ftype (function (cons stream) t) dump-cons)) (defun dump-cons (object stream) - (cond ((and (eq (car object) 'QUOTE) (= (length object) 2)) + (cond ((and (eq (car object) 'QUOTE) (proper-list-of-length-p object 2)) (%stream-write-char #\' stream) (dump-object (%cadr object) stream)) (t From mevenson at common-lisp.net Wed Jan 16 10:45:56 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 16 Jan 2013 02:45:56 -0800 Subject: [armedbear-cvs] r14355 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: mevenson Date: Wed Jan 16 02:45:54 2013 New Revision: 14355 Log: Fix loop and default value for of-type problem. Patch and (most of) test by Stas. Fixes #293. Modified: trunk/abcl/src/org/armedbear/lisp/loop.lisp trunk/abcl/test/lisp/abcl/bugs.lisp Modified: trunk/abcl/src/org/armedbear/lisp/loop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/loop.lisp Mon Jan 14 02:01:01 2013 (r14354) +++ trunk/abcl/src/org/armedbear/lisp/loop.lisp Wed Jan 16 02:45:54 2013 (r14355) @@ -976,10 +976,23 @@ (defun loop-typed-init (data-type &optional step-var-p) (when (and data-type (subtypep data-type 'number)) - (if (or (subtypep data-type 'float) - (subtypep data-type '(complex float))) - (coerce (if step-var-p 1 0) data-type) - (if step-var-p 1 0)))) + ;; From SBCL + (let ((init (if step-var-p 1 0))) + (flet ((like (&rest types) + (coerce init (find-if (lambda (type) + (subtypep data-type type)) + types)))) + (cond ((subtypep data-type 'float) + (like 'single-float 'double-float + 'short-float 'long-float 'float)) + ((subtypep data-type '(complex float)) + (like '(complex single-float) + '(complex double-float) + '(complex short-float) + '(complex long-float) + '(complex float))) + (t + init)))))) (defun loop-optional-type (&optional variable) ;; No variable specified implies that no destructuring is permissible. Modified: trunk/abcl/test/lisp/abcl/bugs.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/bugs.lisp Mon Jan 14 02:01:01 2013 (r14354) +++ trunk/abcl/test/lisp/abcl/bugs.lisp Wed Jan 16 02:45:54 2013 (r14355) @@ -125,3 +125,11 @@ (deftest bugs.pathname.make-pathname.2 (probe-file (make-pathname :device (list "foo"))) nil) + +;; http://trac.common-lisp.net/armedbear/ticket/293 +(deftest bugs.loop.1 + (loop :with x :of-type (float 0) = 0.0 + :for y :upto 1 + :collecting (cons x y)) + ((0.0 . 0) (0.0 . 1))) + From mevenson at common-lisp.net Wed Jan 16 10:48:26 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 16 Jan 2013 02:48:26 -0800 Subject: [armedbear-cvs] r14356 - in branches/1.1.x: src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: mevenson Date: Wed Jan 16 02:48:24 2013 New Revision: 14356 Log: Backport r14355 | mevenson | 2013-01-16 11:45:54 +0100 (Wed, 16 Jan 2013) | 5 lines. Fix loop and default value for of-type problem. Patch and (most of) test by Stas. Fixes #293. Modified: branches/1.1.x/src/org/armedbear/lisp/loop.lisp branches/1.1.x/test/lisp/abcl/bugs.lisp Modified: branches/1.1.x/src/org/armedbear/lisp/loop.lisp ============================================================================== --- branches/1.1.x/src/org/armedbear/lisp/loop.lisp Wed Jan 16 02:45:54 2013 (r14355) +++ branches/1.1.x/src/org/armedbear/lisp/loop.lisp Wed Jan 16 02:48:24 2013 (r14356) @@ -976,10 +976,23 @@ (defun loop-typed-init (data-type &optional step-var-p) (when (and data-type (subtypep data-type 'number)) - (if (or (subtypep data-type 'float) - (subtypep data-type '(complex float))) - (coerce (if step-var-p 1 0) data-type) - (if step-var-p 1 0)))) + ;; From SBCL + (let ((init (if step-var-p 1 0))) + (flet ((like (&rest types) + (coerce init (find-if (lambda (type) + (subtypep data-type type)) + types)))) + (cond ((subtypep data-type 'float) + (like 'single-float 'double-float + 'short-float 'long-float 'float)) + ((subtypep data-type '(complex float)) + (like '(complex single-float) + '(complex double-float) + '(complex short-float) + '(complex long-float) + '(complex float))) + (t + init)))))) (defun loop-optional-type (&optional variable) ;; No variable specified implies that no destructuring is permissible. Modified: branches/1.1.x/test/lisp/abcl/bugs.lisp ============================================================================== --- branches/1.1.x/test/lisp/abcl/bugs.lisp Wed Jan 16 02:45:54 2013 (r14355) +++ branches/1.1.x/test/lisp/abcl/bugs.lisp Wed Jan 16 02:48:24 2013 (r14356) @@ -125,3 +125,11 @@ (deftest bugs.pathname.make-pathname.2 (probe-file (make-pathname :device (list "foo"))) nil) + +;; http://trac.common-lisp.net/armedbear/ticket/293 +(deftest bugs.loop.1 + (loop :with x :of-type (float 0) = 0.0 + :for y :upto 1 + :collecting (cons x y)) + ((0.0 . 0) (0.0 . 1))) + From mevenson at common-lisp.net Wed Jan 16 12:27:34 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 16 Jan 2013 04:27:34 -0800 Subject: [armedbear-cvs] r14357 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: mevenson Date: Wed Jan 16 04:27:33 2013 New Revision: 14357 Log: Fixes #294: Reader doesn't recognize terminating characters in some cases. Patch and test by Stas. Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java trunk/abcl/test/lisp/abcl/bugs.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java Wed Jan 16 02:48:24 2013 (r14356) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Wed Jan 16 04:27:33 2013 (r14357) @@ -739,18 +739,11 @@ private static final boolean isTokenDelimiter(char c, Readtable rt) { - switch (c) { - case '"': - case '\'': - case '(': - case ')': - case ',': - case ';': - case '`': - return true; - default: - return rt.isWhitespace(c); - } + byte type = rt.getSyntaxType(c); + + return type == Readtable.SYNTAX_TYPE_TERMINATING_MACRO || + type == Readtable.SYNTAX_TYPE_WHITESPACE; + } public LispObject readDispatchChar(char dispChar, @@ -909,7 +902,8 @@ c = (char) n; // ### BUG: Codepoint conversion if (rt.isWhitespace(c)) break; - if (c == '(' || c == ')') { + if (rt.getSyntaxType(c) == + Readtable.SYNTAX_TYPE_TERMINATING_MACRO) { _unreadChar(c); break; } Modified: trunk/abcl/test/lisp/abcl/bugs.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/bugs.lisp Wed Jan 16 02:48:24 2013 (r14356) +++ trunk/abcl/test/lisp/abcl/bugs.lisp Wed Jan 16 04:27:33 2013 (r14357) @@ -133,3 +133,11 @@ :collecting (cons x y)) ((0.0 . 0) (0.0 . 1))) + +;; http://trac.common-lisp.net/armedbear/ticket/294 +(deftest bugs.reader.1 + (let ((*readtable* *readtable*)) + (set-macro-character #\? (lambda (stream char) (code-char (read stream nil nil t)))) + '(a .?0)) + (A . #\Null)) + From mevenson at common-lisp.net Wed Jan 16 12:28:41 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 16 Jan 2013 04:28:41 -0800 Subject: [armedbear-cvs] r14358 - in branches/1.1.x: src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: mevenson Date: Wed Jan 16 04:28:40 2013 New Revision: 14358 Log: Backport r14357 | mevenson | 2013-01-16 13:27:33 +0100 (Wed, 16 Jan 2013) | 3 lines. Fixes #294: Reader doesn't recognize terminating characters in some cases. Patch and test by Stas. Modified: branches/1.1.x/src/org/armedbear/lisp/Stream.java branches/1.1.x/test/lisp/abcl/bugs.lisp Modified: branches/1.1.x/src/org/armedbear/lisp/Stream.java ============================================================================== --- branches/1.1.x/src/org/armedbear/lisp/Stream.java Wed Jan 16 04:27:33 2013 (r14357) +++ branches/1.1.x/src/org/armedbear/lisp/Stream.java Wed Jan 16 04:28:40 2013 (r14358) @@ -739,18 +739,11 @@ private static final boolean isTokenDelimiter(char c, Readtable rt) { - switch (c) { - case '"': - case '\'': - case '(': - case ')': - case ',': - case ';': - case '`': - return true; - default: - return rt.isWhitespace(c); - } + byte type = rt.getSyntaxType(c); + + return type == Readtable.SYNTAX_TYPE_TERMINATING_MACRO || + type == Readtable.SYNTAX_TYPE_WHITESPACE; + } public LispObject readDispatchChar(char dispChar, @@ -909,7 +902,8 @@ c = (char) n; // ### BUG: Codepoint conversion if (rt.isWhitespace(c)) break; - if (c == '(' || c == ')') { + if (rt.getSyntaxType(c) == + Readtable.SYNTAX_TYPE_TERMINATING_MACRO) { _unreadChar(c); break; } Modified: branches/1.1.x/test/lisp/abcl/bugs.lisp ============================================================================== --- branches/1.1.x/test/lisp/abcl/bugs.lisp Wed Jan 16 04:27:33 2013 (r14357) +++ branches/1.1.x/test/lisp/abcl/bugs.lisp Wed Jan 16 04:28:40 2013 (r14358) @@ -133,3 +133,11 @@ :collecting (cons x y)) ((0.0 . 0) (0.0 . 1))) + +;; http://trac.common-lisp.net/armedbear/ticket/294 +(deftest bugs.reader.1 + (let ((*readtable* *readtable*)) + (set-macro-character #\? (lambda (stream char) (code-char (read stream nil nil t)))) + '(a .?0)) + (A . #\Null)) + From mevenson at common-lisp.net Thu Jan 17 11:16:05 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 17 Jan 2013 03:16:05 -0800 Subject: [armedbear-cvs] r14359 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu Jan 17 03:15:14 2013 New Revision: 14359 Log: Refactor autoload functions to naming conventions. 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 Wed Jan 16 04:28:40 2013 (r14358) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Thu Jan 17 03:15:14 2013 (r14359) @@ -98,7 +98,6 @@ "org.armedbear.lisp.".concat(className))); } - private static void effectiveLoad(String className, String fileName) { if (className != null) { try { @@ -276,10 +275,14 @@ return unreadableString(sb.toString()); } - // ### autoload - private static final Primitive AUTOLOAD = - new Primitive("autoload", PACKAGE_EXT, true) - { + public static final Primitive AUTOLOAD = new pf_autoload(); + @DocString(name="autoload", + args="symbol-or-symbols filename", + doc="Setup the autoload for SYMBOL-OR-SYMBOLS optionally corresponding to FILENAME.") + private static final class pf_autoload extends Primitive { + pf_autoload() { + super("autoload", PACKAGE_EXT, true); + } @Override public LispObject execute(LispObject first) { @@ -318,14 +321,16 @@ } }; - // ### resolve - // Force autoload to be resolved. - private static final Primitive RESOLVE = - new Primitive("resolve", PACKAGE_EXT, true, "symbol") - { + public static final Primitive RESOLVE = new pf_resolve(); + @DocString(name="resolve", + args="symbol", + doc="Force the symbol to be resolved via the autoloader mechanism.") + private static final class pf_resolve extends Primitive { + pf_resolve() { + super("resolve", PACKAGE_EXT, true, "symbol"); + } @Override - public LispObject execute(LispObject arg) - { + public LispObject execute(LispObject arg) { Symbol symbol = checkSymbol(arg); LispObject fun = symbol.getSymbolFunction(); if (fun instanceof Autoload) { @@ -335,12 +340,17 @@ } return fun; } - }; + } - // ### autoloadp - private static final Primitive AUTOLOADP = - new Primitive("autoloadp", PACKAGE_EXT, true, "symbol") - { + public static final Primitive AUTOLOADP = new pf_autoloadp(); + @DocString(name="autoloadp", + args="symbol", + doc="Boolean predicate for whether SYMBOL stands for a function that currently needs to be autoloaded.") + private static final class pf_autoloadp extends Primitive { + pf_autoloadp() { + super("autoloadp", PACKAGE_EXT, true, "symbol"); + } + @Override public LispObject execute(LispObject arg) { From rschlatte at common-lisp.net Sat Jan 19 17:35:45 2013 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sat, 19 Jan 2013 09:35:45 -0800 Subject: [armedbear-cvs] r14360 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sat Jan 19 09:35:45 2013 New Revision: 14360 Log: add #\Delete character name (found in McCLIM sources) 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 Thu Jan 17 03:15:14 2013 (r14359) +++ trunk/abcl/src/org/armedbear/lisp/LispCharacter.java Sat Jan 19 09:35:45 2013 (r14360) @@ -578,7 +578,7 @@ return 27; if (lower.equals("space") || lower.equals("sp")) return ' '; - if (lower.equals("rubout") || lower.equals("del")) + if (lower.equals("rubout") || lower.equals("del") || lower.equals("delete")) return 127; if (lower.startsWith("u")) { int length = lower.length(); From mevenson at common-lisp.net Sun Jan 27 09:47:50 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 27 Jan 2013 01:47:50 -0800 Subject: [armedbear-cvs] r14361 - in trunk/abcl: doc/asdf src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun Jan 27 01:47:48 2013 New Revision: 14361 Log: asdf-2.26.143.1: pre asdf-2.27 plus workaround for SETF autoloader problems. 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 Sat Jan 19 09:35:45 2013 (r14360) +++ trunk/abcl/doc/asdf/asdf.texinfo Sun Jan 27 01:47:48 2013 (r14361) @@ -21,6 +21,12 @@ @macro &body &body @end macro + at macro &curly +{ + at end macro + at macro &ylruc +} + at end macro @c for install-info @dircategory Software development @@ -211,7 +217,7 @@ @section Loading a pre-installed ASDF -Many Lisp implementations include a copy of ASDF. +Most recent Lisp implementations include a copy of ASDF 2. You can usually load this copy using Common Lisp's @code{require} function: @lisp @@ -221,7 +227,7 @@ As of the writing of this manual, the following implementations provide ASDF 2 this way: abcl allegro ccl clisp cmucl ecl lispworks mkcl sbcl xcl. -The following implementation doesn't provide it yet but will in a future release: +The following implementation doesn't provide it yet but will in an upcoming release: scl. The following implementations are obsolete, not actively maintained, and most probably will never bundle it: @@ -261,13 +267,20 @@ or none at all: @lisp -(or #+asdf2 (asdf:asdf-version) #+asdf :old) +(when (find-package :asdf) + (let ((ver (symbol-value (or (find-symbol (string :*asdf-version*) :asdf) + (find-symbol (string :*asdf-revision*) :asdf))))) + (etypecase ver + (string ver) + (cons (with-output-to-string (s) + (loop for (n . m) on ver do (princ n s) (when m (princ "." s))))) + (null "1.0")))) @end lisp -If it returns a version number, that's the version of ASDF installed. -If it returns the keyword @code{:OLD}, -then you're using an old version of ASDF (from before 1.635). If it returns @code{NIL} then ASDF is not installed. +Otherwise it should return a string. +If it returns @code{"1.0"}, then it can actually be +any version before 1.77 or so, or some buggy variant of 1.x. If you are experiencing problems with ASDF, please try upgrading to the latest released version, @@ -277,12 +290,18 @@ @section Upgrading ASDF +If your implementation provides ASDF 2.27 or later, +you only need to @code{(require "asdf")}: +ASDF will automatically look whether an updated version of itself is available +amongst the regularly configured systems, before it compiles anything else. +See @pxref{Configuring ASDF} below. + If your implementation does provide ASDF 2 or later, +but not ASDF 2.27 or later, and you want to upgrade to a more recent version, -just install ASDF like any other package -(see @pxref{Loading ASDF,,Loading an otherwise installed ASDF} below), -configure ASDF as usual (see @pxref{Configuring ASDF} below), -and upgrade with: +you need to install and configure your ASDF as above, +and additionally, you need to explicitly tell ASDF to load itself, +right after you require your implementation's old ASDF 2: @lisp (require "asdf") @@ -290,7 +309,9 @@ @end lisp If on the other hand, your implementation only provides an old ASDF, -you will require a special configuration step and an old-style loading: +you will require a special configuration step and an old-style loading. +Take special attention to not omit the trailing directory separator + at code{/} at the end of your pathname: @lisp (require "asdf") @@ -298,9 +319,7 @@ (asdf:oos 'asdf:load-op :asdf) @end lisp -Don't forget the trailing @code{/} at the end of your pathname. - -Also, note that older versions of ASDF won't redirect their output, +Note that ASDF 1 won't redirect its output files, or at least won't do it according to your usual ASDF 2 configuration. You therefore need write access on the directory where you install the new ASDF, @@ -312,21 +331,36 @@ provide ASDF 2 in their latest release, so you may want to upgrade your implementation rather than go through that hoop. -Finally, note that there are some limitations to upgrading ASDF: +Finally, if you are using an unmaintained implementation +that does not provide ASDF at all, +see @pxref{Loading ASDF,,Loading an otherwise installed ASDF} below. + +Note that there are some limitations to upgrading ASDF: @itemize @item -Any ASDF extension becomes invalid, and will need to be reloaded. +Previously loaded ASDF extension becomes invalid, and will need to be reloaded. This applies to e.g. CFFI-Grovel, or to hacks used by ironclad, etc. -Starting with ASDF 2.014.8 (as far as releases go, 2.015), +Since it isn't possible to automatically detect what extensions are present +that need to be invalidated, ASDF will actually invalidate all previously loaded systems -when it is loaded on top of a different ASDF version. +when it is loaded on top of a different ASDF version, +starting with ASDF 2.014.8 (as far as releases go, 2.015); +and it will automatically attempt this self-upgrade as its very first step +starting with ASDF 2.27. + @item -Until all implementations provide ASDF 2.015 or later, +For this an many other reasons, +it important reason to load, configure and upgrade ASDF (if needed) +as one of the very first things done by your build and startup scripts. +Until all implementations provide ASDF 2.27 or later, it is safer if you upgrade ASDF and its extensions as a special step at the very beginning of whatever script you are running, -before you start using ASDF to load anything else. +before you start using ASDF to load anything else; +even afterwards, it is still a good idea, to avoid having to +load and reload code twice as it gets invalidated. + @item -Until all implementations provide ASDF 2.015 or later, +Until all implementations provide ASDF 2.27 or later, it is unsafe to upgrade ASDF as part of loading a system that depends on a more recent version of ASDF, since the new one might shadow the old one while the old one is running, @@ -394,7 +428,8 @@ The default location for a user to install Common Lisp software is under @file{~/.local/share/common-lisp/source/}. -If you install software there, you don't need further configuration. +If you install software there (it can be a symlink), +you don't need further configuration. If you're installing software yourself at a location that isn't standard, you have to tell ASDF where you installed it. See below. If you're using some tool to install software (e.g. Quicklisp), @@ -438,6 +473,8 @@ if the configuration may change between the machine where you save it at the time you save it and the machine you resume it at the time you resume it. +Actually, you should use @code{(asdf:clear-configuration)} +before you dump your Lisp image, which includes the above. @section Configuring ASDF to find your systems --- old style @@ -593,6 +630,8 @@ if the configuration may change between the machine where you save it at the time you save it and the machine you resume it at the time you resume it. +(Once again, you should use @code{(asdf:clear-configuration)} +before you dump your Lisp image, which includes the above.) Finally note that before ASDF 2, other ASDF add-ons offered the same functionality, @@ -719,7 +758,7 @@ thanks to proper source-registry configuration. @item -Load a system with @code{(load-system :my-system)} +Load a system with @code{(asdf:load-system :my-system)} or use some other operation on some system of your choice. @end itemize @@ -833,7 +872,17 @@ In particular, version @code{0.2.1} is interpreted the same as @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 +Instead of a string representing the version, +the @code{:version} argument can be an expression that is resolved to +such a string using the following trivial domain-specific language: +in addition to being a literal string, it can be an expression of the form + at code{(:read-file-form :at )}, +which will be resolved by reading a form +in the specified pathname +(read as a subpathname of the current system if relative or a unix-namestring). +You may use an access-at specifier with the (optional) :at keyword, +by default the specifier is 0, meaning the first form is returned. + @cindex :version @end itemize @@ -922,7 +971,6 @@ module-option := :components component-list | :serial [ t | nil ] - | :if-component-dep-fails component-dep-fail-option option := | :pathname pathname-specifier @@ -931,6 +979,7 @@ | :explain method-form | :output-files method-form | :operation-done-p method-form + | :if-feature feature-expression | :depends-on ( @var{dependency-def}* ) | :in-order-to ( @var{dependency}+ ) @@ -964,6 +1013,9 @@ qual := method qualifier component-dep-fail-option := :fail | :try-next | :ignore + +feature-expression := keyword | (:and @var{feature-expression}*) + | (:or @var{feature-expression}*) | (:not @var{feature-expression}) @end example @@ -1011,16 +1063,27 @@ @subsection Weakly depends on @cindex :weakly-depends-on -The @code{:weakly-depends-on} option to @code{defsystem} allows the -programmer to specify another ASDF-defined system or set of systems that -ASDF should @emph{try} to load, but need not load in order to be -successful. Typically this is used if there are a number of systems -that, if present, could provide additional functionality, but which are -not necessary for basic function. - -Currently, although it is specified to be an option only to - at code{defsystem}, this option is accepted at any component, but it probably -only makes sense at the @code{defsystem} level. Programmers are cautioned not +We do @emph{NOT} recommend you use this feature. +If you are tempted to write a system @var{foo} +that weakly-depends-on a system @var{bar}, +we recommend that you should instead +write system @var{foo} in a parametric way, +and offer some special variable and/or some hook to specialize its behavior; +then you should write a system @var{foo+bar} +that does the hooking of things together. + +The (deprecated) @code{:weakly-depends-on} option to @code{defsystem} +allows the programmer to specify another ASDF-defined system or set of systems +that ASDF should @emph{try} to load, +but need not load in order to be successful. +Typically this is used if there are a number of systems +that, if present, could provide additional functionality, +but which are not necessary for basic function. + +Currently, although it is specified to be an option only to @code{defsystem}, +this option is accepted at any component, but it probably +only makes sense at the @code{defsystem} level. +Programmers are cautioned not to use this component option except at the @code{defsystem} level, as this anomalous behavior may be removed without warning. @@ -1092,6 +1155,8 @@ Unhappily, ASDF 1 didn't properly support parsing component names as strings specifying paths with directories, and the cumbersome @code{#.(make-pathname ...)} syntax had to be used. +An alternative to @code{#.} read-time evaluation is to use + at code{(eval `(defsystem ... ,pathname ...))}. Note that when specifying pathname objects, ASDF does not do any special interpretation of the pathname @@ -1209,6 +1274,7 @@ @code{find-system} will load a system from disk and have its pathname default to the right place. + @item This pathname information will not be overwritten with @code{*default-pathname-defaults*} @@ -1234,8 +1300,10 @@ @item changed, if explicitly supplied or obtained from @code{*load-truename*} (so that an updated source location is reflected in the system definition) + @item changed if it had previously been set from @code{*default-pathname-defaults*} + @item left as before, if it had previously been set from @code{*load-truename*} and @code{*load-truename*} is currently unbound @@ -1243,12 +1311,21 @@ from within an editor without clobbering its source location) @end itemize - at subsection if-component-dep-fails option - -This option is only appropriate for module components (including -systems), not individual source files. + at subsection if-feature option +This option allows you to specify a feature expression to be evaluated +as if by @code{#+} to conditionally include a component in your build. +If the expression is false, the component is dropped +as well as any dependency pointing to it. +As compared to using @code{#+} which is expanded at read-time, +this allows you to have an object in your component hierarchy +that can be used for manipulations beside building your project. +This option was added in ASDF 2.27. -For more information about this option, @pxref{Pre-defined subclasses of component}. + at subsection if-component-dep-fails option +This option was removed in ASDF 2.27. +Its semantics was limited in purpose and dubious to explain, +and its implementation was breaking a hole into the ASDF object model. +Please use the @code{if-feature} option instead. @node Other code in .asd files, , The defsystem grammar, Defining systems with defsystem @section Other code in .asd files @@ -1279,17 +1356,107 @@ ASDF is designed in an object-oriented way from the ground up. Both a system's structure and the operations that can be performed on systems -follow a protocol. -ASDF is extensible to new operations and to new component types. -This allows the addition of behaviours: -for example, a new component could be added for Java JAR archives, -and methods specialised on @code{compile-op} added for it -that would accomplish the relevant actions. - -This chapter deals with @emph{components}, the building blocks of a system, -and @emph{operations}, the actions that can be performed on a system. - +follow a extensible protocol. +This allows the addition of behaviours: +for example, @code{cffi} adds support of special FFI description files +to interface with C libraries and of wrapper files to embed C code in Lisp; + at code{abcl-jar} supports creating Java JAR archives in ABCL; +and @code{poiu} supports for compiling code in parallel using background processes. + +This chapter deals with @code{component}s and @code{operation}s. + +A @code{component} represents an individual source file or a group of source files, +and the things that get transformed into. +A @code{system} is a component at the top level of the component hierarchy. +A @code{source-file} is a component representing a single source-file +and the successive output files into which it is transformed. +A @code{module} is an intermediate component itself grouping several other components, +themselves source-files or further modules. + +An @code{Operation} represents a transformation that can be performed on a component, +turning them from source files to intermediate results to final outputs. + +A pair of an @code{operation} and a @code{component} is called an @code{action}. +An @code{action} represents a particular build step to be @code{perform}ed, +after all its dependencies have been fulfilled. +In the ASDF model, actions depend on other actions. +The term @emph{action} itself was used by Kent Pitman in his old article, +but was only used by ASDF hackers starting with the ASDF 2; +but the concept is ubiquitous since the very beginning of ASDF 1, +though previously implicit. + +Then, there are many @emph{functions} available +to users, extenders and implementers of ASDF +to use, define or implement the activities +that are part of building your software. +Though they manipulate @code{action}s, +most of these functions do not take as an argument +a reified pair (a CONS cell) of an operation and a component; +instead, they usually take two separate arguments, +which allows to take advantage of the power CLOS-style multiple dispatch +for fun and profit. + +There are many @emph{hooks} in which to add functionality, +by customizing the behavior of existing @emph{functions}. + +Last but not least is the notion of @emph{dependency} between two actions. +The structure of dependencies between actions is +a directed @emph{dependency graph}. +ASDF is invoked by being told to @emph{operate} +with some @emph{operation} on some toplevel @emph{system}; +it will then @emph{traverse} the graph and build a @emph{plan} +that follows its structure. +To be successfully buildable, this graph of actions but be acyclic. +If, as a user, extender or implementer of ASDF, you fail +to keep the dependency graph without cycles, +ASDF will fail loudly as it eventually finds one. + +To clearly distinguish the direction of dependencies, +ASDF 2.27 introduces the words @emph{parent} and @emph{child} +as applied to an action depending on the other: +the parent action @code{depends-on} the completion of all children actions +before it may itself be @code{perform}ed. +ASDF has long had parent operations and children operations, +whereby the ancestor holds some options valid for all the children (notably regarding forcing). + +Using the defsystem syntax, users may easily express +direct dependencies along the graph of the object hierarchy: +between a component and its parent, its children, and its siblings. +By defining custom CLOS methods, you can express more elaborate dependencies as you wish. +Most common operations, such as @code{load-op}, @code{compile-op} or @code{load-source-op} +automatically ``descend'' the component hierarchy and are ``covariant'' with it: +to act the operation on the parent module, you must first act it on all the children components, +with the action on the parent being parent of the action on each child. +Other operations, such as @code{parent-load-op} and @code{parent-load-source-op} +(introduced in ASDF 2.27) ``ascend'' the component hierarchy and are ``contravariant'' with it: +to act the operation on the child component, you must first act it on all its parent module, and so on, +ensuring that all the module's dependencies are (compiled and) loaded +before the child component may be compiled and loaded. +Yet other operations, such as @code{test-op} or @code{load-fasl-op} +remain at the system level, and do not descend the hierarchy, +instead doing something global. +Finally, some operations such a POIU's @code{parallel-load-op} +are not even meant to be performed or to have dependencies, +but are only ways to specialize @code{operate} into behaving differently +(in this case, having it operate in parallel). + +Parent and child thus mean different things for components and for actions. +They also mean two different things for operations. +Each operation has a @code{parent} slot, +which links it up all the way to an ancestor @emph{operation} +that contains all configuration data related to the current run of @code{operate} +(usually the links are made with @code{make-sub-operation} +which ensures the chain or parents is of length zero or one). +Each operation also has a notion of a @code{parent-operation}, +such that current operation acting on a current component +is parent of the parent-operation acting on the parent. +That's how @code{parent-load-op} is the @code{parent-operation} +or both @code{load-op} and @code{compile-op} (see above). + +It isn't too confusing: parent and child are generic ways to denote a clear directional relationship, +and whether we're discussing component structure, action structure, operation structure +or contravariant operation prerequisites, it is usually very clear which relationship we're discussing. @menu * Operations:: @@ -1313,7 +1480,6 @@ Operations can be invoked directly, or examined to see what their effects would be without performing them. - at emph{FIXME: document how!} There are a bunch of methods specialised on operation and component type that actually do the grunt work. @@ -1340,16 +1506,28 @@ the new operations will be created with the same @var{initargs} as the original one. -If @var{force} is @code{t}, then all systems +If @var{force} is @code{:all}, then all systems are forced to be recompiled even if not modified since last compilation. +If @var{force} is @code{t}, then only the system being loaded +is forced to be recompiled even if not modified since last compilation, +but other systems are not affected. If @var{force} is a list, then it specifies a list of systems that are forced to be recompiled even if not modified since last compilation. -If @var{force-not} is @code{t}, then all systems +If @var{force-not} is @code{:all}, then all systems are forced not to be recompiled even if modified since last compilation. +If @var{force-not} is @code{t}, then only the system being loaded +is forced not to be recompiled even if modified since last compilation, +but other systems are not affected. If @var{force-not} is a list, then it specifies a list of systems that are forced not to be recompiled even if modified since last compilation. @var{force} takes precedences over @var{force-not}; both of them apply to systems that are dependencies and were already compiled. + +To see what @code{operate} would do, you can use: + at example +(asdf::traverse (make-instance operation-class initargs ...) (find-system system-name)) + at end example + @end deffn @menu @@ -1393,6 +1571,19 @@ For parity, your own methods on new component types should probably do so too. @end deffn + at deffn Operation @code{parent-load-op} @&key @code{proclamations} + +This operation ensures that the dependencies +of a module, and its parent, and so on, are loaded (as per @code{load-op}) +before the components within that module may be operated upon. + +By default, all operations depend on this @code{parent-operation} +for actions on components to depend on this ``parent operation'' being acted on the parent. + +The default methods for @code{load-op} compile files before loading them. +For parity, your own methods on new component types should probably do so too. + at end deffn + @deffn Operation @code{load-source-op} This operation will load the source for the files in a module @@ -1423,8 +1614,50 @@ should signal its results to the user in a way that is compatible with all of the various test libraries and test techniques in use in the community. + +People typically define @code{test-op} methods like thus: + at example +(defmethod perform ((o asdf:test-op) (s (eql (asdf:find-system @var{:mysystem})))) + (asdf:load-system @var{:mysystem}) + (eval (read-from-string "(some expression that runs the tests)")) + t) + at end example @end deffn + at deffn Operation @code{load-fasl-op} + +This operation will load and create if need be +a single fasl file for all the files in each loaded system. +(Its compilation-only equivalent is @code{asdf::fasl-op}.) + +Once you have created such a fasl, +you can use @code{precompiled-system} to deliver it in a way +that is compatible with clients having asdf dependencies +on your system whether it is distributed as source of as a single binary. + +On your build platform, you run something like that: + at example + at code{(asdf:operate 'load-fasl-op @var{:mysystem})} + at end example + +And on your delivery platform, a form like this is evaluated +in a prologue or at some point before you save your image: + at example +(defsystem :mysystem :class :precompiled-system + :fasl (some expression that will evaluate to a pathname)) + at end example + +Of course, @emph{before} you define such systems, +you should not forget to @code{(asdf:clear-configuration)}. + + at code{load-fasl-op} is available on all actively supported Lisp implementations, +and on those implementations only, and only since ASDF 2.27. +This functionality was previously available for select implementations, +as part of a separate system @code{asdf-bundle}, +itself descended from @code{asdf-ecl}. + at end deffn + + @c @deffn Operation test-system-version @&key minimum @c Asks the system whether it satisfies a version requirement. @@ -1483,6 +1716,12 @@ @itemize + at item @code{input-files} +ASDF has a pretty clever default @code{input-files} mechanism. +You only need create a method if there are multiple ultimate input files, +and/or the bottom one doesn't depend +on the @code{component-pathname} of the component. + @item @code{output-files} The @code{output-files} method determines where the method will put its files. It returns two values, a list of pathnames, and a boolean. @@ -1491,14 +1730,67 @@ If the boolean is @code{NIL} then enclosing @code{:around} methods may translate these pathnames, e.g. to ensure object files are somehow stored in some implementation-dependent cache. + @item @code{perform} The @code{perform} method must call @code{output-files} to find out where to put its files, because the user is allowed to override. @item @code{output-files} for local policy @code{explain} - at item @code{operation-done-p}, -if you don't like the default one + + at item @code{operation-done-p} +You only need to define a method on that function +if you can detect conditions that invalidate previous runs of the operation, +even though no filesystem timestamp has changed, +in which case you return @code{nil} (the default is @code{t}). + +For instance, the method for @code{test-op} always returns @code{nil}, +so that tests are always run afresh. +Of course, the @code{test-op} for your system could depend +on a deterministically repeatable @code{test-report-op}, +and just read the results from the report files. + + at item @code{component-depends-on} +When you add new operations, you probably need to explain +how they relate to loading, compiling, testing, etc., +in terms of dependencies between actions. + +That's where you typically define methods on @code{component-depends-on}. +Your method will take as arguments +some properly specialized operation +and a component denoting a current action, +and return a list of entries, +denoting the children actions that the current action depends on. +The format of entries is described below. + +It is @emph{strongly} advised that +you should always append the results of @code{(call-next-method)} +to the results of your method, +or ``interesting'' failures will likely occur, +unless you're a true specialist of ASDF internals. + +Each entry returned by @code{component-depends-on} is itself a list. + +The first element of an entry is the name of an operation: +a symbol that you can use with @code{make-instance} +(ASDF will instead use with @code{asdf::make-sub-operation}), +to create a related operation for use in a build plan. +For instance, @code{load-op} and @code{compile-op} +are common such names, denoting the respective operations. + +The rest of an entry is a list of identifiers +each denote a component such that +the pair of the previous operation and this component +is a children action of current action. + +Identifiers follow the @code{defsystem} grammar +previously documented. +The main format for identifiers is a string or symbol +(that will be downcase as per @code{coerce-name}), +and looked up against the sibling list of the parent module's children components, +as per @code{find-component}. +As a special case, @code{nil} denotes the parent itself. +Other syntaxes are allowed, for instance to specify a component with a version. @end itemize @@ -1684,7 +1976,7 @@ mk-defsystem is less general: it has an implied dependency @verbatim - for all x, (load x) depends on (compile x) + for all source file x, (load x) depends on (compile x) @end verbatim and using a @code{:depends-on} argument to say that @var{b} depends on @@ -1803,15 +2095,8 @@ @item @code{:if-component-dep-fails} -This attribute takes one of the values - at code{:fail}, @code{:try-next}, @code{:ignore}, -its default value is @code{:fail}. -The other values can be used for implementing conditional compilation -based on implementation @code{*features*}, -for the case where it is not necessary for all files in a module to be -compiled. - at emph{FIXME: such conditional compilation has been reported -to be broken in 2009.} +This attribute was removed in ASDF 2.27. Do not use it. +Use @code{:if-feature} instead. @item @code{:serial} When this attribute is set, @@ -1987,6 +2272,30 @@ may be automatically prepended to whatever directories are specified in configuration files, no matter if the last one inherits or not. + + at section Truenames and other dangers + +One great innovation of the original ASDF was its ability to leverage + at code{CL:TRUENAME} to locate where your source code was and where to build it, +allowing for symlink farms as a simple but effective configuration mechanism +that is easy to control programmatically. +ASDF2 still supports this configuration style, and it is enabled by default; +however we recommend you instead use +our source-registry configuration mechanism described below, +because it is easier to setup in a portable way across users and implementations. + +Addtionally, some people dislike truename, +either because it is very slow on their system, or +because they are using content-addressed storage where the truename of a file +is related to a digest of its individual contents, +and not to other files in the same intended project. +For these people, ASDF 2.27 allows to eschew the @code{TRUENAME} mechanism, +by setting the variable @var{asdf:*resolve-symlinks*} to @code{NIL}. + +PS: Yes, if you haven't read Vernor Vinge's short but great classic +``True Names... and Other Dangers'' then you're in for a treat. + + @section XDG base directory Note that we purport to respect the XDG base directory specification @@ -2004,10 +2313,9 @@ instead of the XDG base directory specification, we try to use folder configuration from the registry regarding @code{Common AppData} and similar directories. -However, support for querying the Windows registry is limited as of ASDF 2, -and on many implementations, we may fall back to always using the defaults -without consulting the registry. -Patches welcome. +Since support for querying the Windows registry +is not possible to do in reasonable amounts of portable Common Lisp code, +ASDF 2 relies on the environment variables that Windows usually exports. @section Backward Compatibility @@ -2321,17 +2629,14 @@ which will cause the initialization to happen next time around. - at section Future - -If this mechanism is successful, in the future, we may declare - at code{asdf:*central-registry*} obsolete and eventually remove it. -Any hook into implementation-specific search mechanisms will by then -have been integrated in the @code{:default-configuration} which everyone -should either explicitly use or implicit inherit. Some shell syntax -for it should probably be added somehow. + at section Status -But we're not there yet. For now, let's see how practical this new -source-registry is. +This mechanism is vastly successful, and we have declared +that @code{asdf:*central-registry*} is not recommended anymore, +though we will continue to support it. +All hooks into implementation-specific search mechanisms +have been integrated in the @code{wrapping-source-registry} +that everyone uses implicitly. @section Rejected ideas @@ -2898,7 +3203,7 @@ When declaring a component (system, module, file), you can specify a keyword argument @code{:around-compile function}. -If left unspecified, +If left unspecified (and therefore unbound), the value will be inherited from the parent component if any, or with a default of @code{nil} if no value is specified in any transitive parent. @@ -2907,15 +3212,13 @@ a lambda-expression (e.g. @code{(lambda (thunk) ...(funcall thunk ...) ...)}) a function object (e.g. using @code{#.#'} but that's discouraged because it prevents the introspection done by e.g. asdf-dependency-grovel), -or a string that when read yields a symbol or a lambda-expression. +or a string that when @code{read} yields a symbol or a lambda-expression. @code{nil} means the normal compile-file function will be called. A non-nil value designates a function of one argument -that will be called with a function that -calls the @code{*compile-op-compile-file-function*} -(usually @code{compile-file*}) -with proper arguments; -the around-compile hook may supply additional arguments -to pass to that @code{*compile-op-compile-file-function*}. +that will be called with a function that will +invoke @code{compile-file*} with various arguments; +the around-compile hook may supply additional keyword arguments +to pass to that call to @code{compile-file*}. One notable argument that is heeded by @code{compile-file*} is @code{:compile-check}, @@ -2923,8 +3226,8 @@ with the same arguments as @code{compile-file}; the function shall return true if the compilation and its resulting compiled file respected all system-specific invariants, -and false (NIL) if it broke any of those invariants; -it may issue warnings or errors before it returns NIL. +and false (@code{nil}) if it broke any of those invariants; +it may issue warnings or errors before it returns @code{nil}. (NB: The ability to pass such extra flags is only available starting with ASDF 2.22.3.) This feature is notably exercised by asdf-finalizers. @@ -3098,7 +3401,11 @@ This might matter, for instance, in meta-data about author's names. - at section Miscellaneous Exported Functions + at section Miscellaneous Functions + +Most of these functions are not exported by ASDF anymore, +but only used for private purposes of ASDF. +Please use ASDF-UTILS for the same functions exported from a stable library. @defun coerce-pathname name @&key type defaults @@ -3193,22 +3500,99 @@ look at the beginning of @file{asdf.lisp} to see what it does. @end defun + at defun run-program + +run-program takes a @var{COMMAND} argument that is either +a list of a program path and its arguments, +or a string to be executed by a shell. +It spawns the command, waits for it to return, +verifies that it exited cleanly (unless told not too below), +and optionally captures and processes its output. +It accepts many keyword arguments to configure its behavior. + + at code{output} is its most important argument; +it specifies how the output is captured and processed. +If it is @code{nil}, then the output is not captured. +If it is @code{:interactive}, then +input and output are inherited from the current process, +which the subprocess can control until it exits. +Otherwise, the output is captured and redirected to a stream, +and processed by @code{slurp-input-stream} with the object as first argument. +See below. + + at code{element-type} and @code{external-format} are passed on +to your Lisp implementation, when available, for creation of the output stream. + + at code{force-shell} forces evaluation of the command through a shell, +even if it was passed as a list rather than a string. + + at code{ignore-error-status} causes @code{run-program} +to not raise an error if the spawned program exits in error. +Following POSIX convention, an error is anything but +a normal exit with status code zero. + +run-program works on all platforms supported by ASDF, except Genera. + + at end defun + + at defun slurp-input-stream + +It's a generic function of two arguments, a target object and an input stream, +and accepting keyword arguments. +Predefined methods based on the target object are as follow: + +If the object is a function, the function is called with the stream as argument. + +If the object is a cons, its first element is applied to its rest appended by +a list of the input stream. + +If the object is an output stream, the contents of the input stream are copied to it. +If the linewise argument is provided, copying happens line by line, +and an optional prefix is printed before each line. +Otherwise, copying happen based on a buffer of size buffer-size, +using the element-type. + +If the object is 'string or :string, the content is captured into a string +of the given element-type. + +If the object is :lines, the content is captured as a list of strings, +one per line, without line ending. If the count argument is provided, +it is a maximum count of lines to be read. + +If the object is :line, the content is capture as with :lines above, +and then its sub-object is extracted with the path argument, +which defaults to 0, extracting the first line. +A number will extract the corresponding line. +See the documentation for asdf-driver:sub-object. + +If the object is :forms, the content is captured as a list of S-expressions, +as read by the Lisp reader. +If the count argument is provided, +it is a maximum count of lines to be read. +We recommend you control the syntax with such macro as +asdf-driver:with-safe-io-syntax. + +If the object is :form, the content is capture as with :forms above, +and then its sub-object is extracted with the path argument, +which defaults to 0, extracting the first form. +A number will extract the corresponding form. +See the documentation for asdf-driver:sub-object. +We recommend you control the syntax with such macro as +asdf-driver:with-safe-io-syntax. + + at end defun + @defun run-shell-command This function is obsolete and present only for the sake of backwards-compatibility: ``If it's not backwards, it's not compatible''. We strongly discourage its use. Its current behavior is only well-defined on Unix platforms (which include MacOS X and cygwin). On Windows, anything goes. +The following documentation is only for the purpose of your migrating away from it +in a way that preserves semantics. -Instead we recommend the use of such a function as - at code{xcvb-driver:run-program/} -from the @code{xcvb-driver} system that is distributed with XCVB: - at url{http://common-lisp.net/project/xcvb}. -It's the only alternative that supports -as many implementations and operating systems as ASDF does, -and provides well-defined behavior outside Unix (i.e. on Windows). -(The only unsupported exception is Genera, since on it - at code{run-shell-command} doesn't make sense anyway on that platform). +Instead we recommend the use @code{run-program} above +available as part of ASDF since ASDF 2.27. @code{run-shell-command} takes as arguments a @code{format} control-string and arguments to be passed to @code{format} after this control-string @@ -3387,11 +3771,17 @@ @itemize @item -The infamous TRAVERSE function has been revamped significantly, -with many bugs squashed. +The infamous TRAVERSE function has been revamped completely +between ASDF 1 and ASDF 2, with many bugs squashed. In particular, dependencies were not correctly propagated -across submodules within a system but now are. -The :version and :feature features and +across modules but now are. +It has been completely rewritten many times over +between ASDF 2.000 and ASDF 2.27, +with fundamental issues in the original model being fixed. +Timestamps were not propagated at all, and now are. +The internal model of how actions depend on each other +is now both consistent and complete. +The :version and the :force (system1 .. systemN) feature have been fixed. @item @@ -3415,7 +3805,7 @@ @item Support was lacking for some implementations. ABCL and GCL were notably wholly broken. -ECL extensions were not integrated in the ASDF release. +ECL extensions were not integrated with ASDF release. @item The documentation was grossly out of date. @@ -3632,8 +4022,8 @@ and precompile it in your binary distribution, but @file{asdf.asd} if included at all, should be secluded from the magic systems, -in a separate file hierarchy; -alternatively, you may provide the system +in a separate file hierarchy. +Alternatively, you may provide the system after renaming it and its @file{.asd} file to e.g. @code{asdf-ecl} and @file{asdf-ecl.asd}, or @code{sb-asdf} and @file{sb-asdf.asd}. @@ -3645,8 +4035,10 @@ @item If you do not have any such magic systems, or have other non-magic systems that you want to bundle with your implementation, -then you may add them to the @code{default-source-registry}, +then you may add them to the @code{wrapping-source-registry}, and you are welcome to include @file{asdf.asd} amongst them. +Non-magic systems should be at the back of the @code{wrapping-source-registry} +while magic systems are at the front. @item Please send us upstream any patches you make to ASDF itself, @@ -3872,7 +4264,7 @@ (in-package :my-asdf-extension) (defclass cl-source-file.lis (cl-source-file) - ((type :initform "lis"))) + ((type :initform "lis"))) @end lisp Then you can use it as follows: @@ -3906,8 +4298,8 @@ you also define the following method: @lisp -(defmethod source-file-type ((f cl-source-file.lis) (m module)) - (declare (ignorable f m)) +(defmethod source-file-type ((f cl-source-file.lis) (s system)) + (declare (ignorable f s)) "lis") @end lisp @@ -3973,39 +4365,7 @@ ** proclamations probably aren't -** (stuff that might happen later) - -*** Propagation of the @code{:force} option. - -``I notice that - - @code{(asdf:compile-system :araneida :force t)} - -also forces compilation of every other system -the @code{:araneida} system depends on. -This is rarely useful to me; -usually, when I want to force recompilation -of something more than a single source file, -I want to recompile only one system. -So it would be more useful to have @code{make-sub-operation} -refuse to propagate @code{:force t} to other systems, and -propagate only something like @code{:force :recursively}. - -Ideally what we actually want is some kind of criterion that says -to which systems (and which operations) a @code{:force} switch will propagate. - -The problem is perhaps that ``force'' is a pretty meaningless concept. -How obvious is it that @code{load :force t} should force @emph{compilation}? -But we don't really have the right dependency setup -for the user to compile @code{:force t} and expect it to work -(files will not be loaded after compilation, so the compile -environment for subsequent files will be emptier than it needs to be) - -What does the user actually want to do when he forces? -Usually, for me, update for use with a new version of the Lisp compiler. -Perhaps for recovery when he suspects that something has gone wrong. -Or else when he's changed compilation options or configuration -in some way that's not reflected in the dependency graph. +** A revert function Other possible interface: have a ``revert'' function akin to @code{make clean}. Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf.lisp Sat Jan 19 09:35:45 2013 (r14360) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Sun Jan 27 01:47:48 2013 (r14361) @@ -1,5 +1,5 @@ -;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- -;;; This is ASDF 2.26.6: Another System Definition Facility. +;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- +;;; This is ASDF 2.26.143.1: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . @@ -47,417 +47,728 @@ #+xcvb (module ()) -(cl:in-package :common-lisp-user) -#+genera (in-package :future-common-lisp-user) +(in-package :cl-user) -#-(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.") +#+abcl +(eval-when (:load-toplevel :compile-toplevel :execute) + (documentation 'car 'function)) ;; workaround (SETF DOCUMENTATION) autoloader bug + +#+cmu +(eval-when (:load-toplevel :compile-toplevel :execute) + (declaim (optimize (speed 1) (safety 3) (debug 3))) + (setf ext:*gc-verbose* nil)) + +#+(or abcl clisp cmu) +(eval-when (:load-toplevel :compile-toplevel :execute) + (unless (member :asdf2.27 *features*) + (let* ((existing-version + (when (find-package :asdf) + (or (symbol-value (find-symbol (string :*asdf-version*) :asdf)) + (let ((ver (symbol-value (find-symbol (string :*asdf-revision*) :asdf)))) + (etypecase ver + (string ver) + (cons (format nil "~{~D~^.~}" ver)) + (null "1.0")))))) + (away (format nil "~A-~A" :asdf existing-version))) + (when existing-version + (rename-package :asdf away) + (when *load-verbose* + (format t "; Renamed package ~A away to ~A~%" :asdf away)))))) -;;;; Create and setup packages in a way that is compatible with hot-upgrade. -;;;; See https://bugs.launchpad.net/asdf/+bug/485687 -;;;; See these two eval-when forms, and more near the end of the file. +;;;; --------------------------------------------------------------------------- +;;;; Handle ASDF package upgrade, including implementation-dependent magic. +;; +;; See https://bugs.launchpad.net/asdf/+bug/485687 +;; +;; CAUTION: we must handle the first few packages specially for hot-upgrade. +;; asdf/package will be frozen as of 2.27 +;; to forever export the same exact symbols. +;; Any other symbol must be import-from'ed +;; and reexported in a different package +;; (alternatively the package may be dropped & replaced by one with a new name). + +(defpackage :asdf/package + (:use :common-lisp) + (:export + #:find-package* #:find-symbol* #:symbol-call + #:intern* #:unintern* #:export* #:make-symbol* + #:symbol-shadowing-p #:home-package-p #:rehome-symbol + #:symbol-package-name #:standard-common-lisp-symbol-p + #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol + #:nuke-symbol-in-package #:nuke-symbol + #:ensure-package-unused #:delete-package* + #:fresh-package-name #:rename-package-away #:package-names #:packages-from-names + #:package-definition-form #:parse-define-package-form + #:ensure-package #:define-package)) + +(in-package :asdf/package) -#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this +;;;; General purpose package utilities (eval-when (:load-toplevel :compile-toplevel :execute) - ;;; Before we do anything, some implementation-dependent tweaks - ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults. - #+allegro - (setf excl::*autoload-package-name-alist* - (remove "asdf" excl::*autoload-package-name-alist* - :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below - #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011 - (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all - (and (= system::*gcl-major-version* 2) - (< system::*gcl-minor-version* 7))) - (pushnew :gcl-pre2.7 *features*)) - #+(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. - (unless (find-package :asdf) - (make-package :asdf :use '(:common-lisp)))) + (defun find-package* (package-designator &optional (error t)) + (let ((package (find-package package-designator))) + (cond + (package package) + (error (error "No package named ~S" (string package-designator))) + (t nil)))) + (defun find-symbol* (name package-designator &optional (error t)) + "Find a symbol in a package of given string'ified NAME; +unless CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax +by letting you supply a symbol or keyword for the name; +also works well when the package is not present. +If optional ERROR argument is NIL, return NIL instead of an error +when the symbol is not found." + (block nil + (let ((package (find-package* package-designator error))) + (when package ;; package error handled by find-package* already + (multiple-value-bind (symbol status) (find-symbol (string name) package) + (cond + (status (return (values symbol status))) + (error (error "There is no symbol ~S in package ~S" name (package-name package)))))) + (values nil nil)))) + (defun symbol-call (package name &rest args) + "Call a function associated with symbol of given name in given package, +with given ARGS. Useful when the call is read before the package is loaded, +or when loading the package is optional." + (apply (find-symbol* name package) args)) + (defun intern* (name package-designator &optional (error t)) + (intern (string name) (find-package* package-designator error))) + (defun export* (name package-designator) + (let* ((package (find-package* package-designator)) + (symbol (intern* name package))) + (export (or symbol (list symbol)) package))) + (defun make-symbol* (name) + (etypecase name + (string (make-symbol name)) + (symbol (copy-symbol name)))) + (defun unintern* (name package-designator &optional (error t)) + (block nil + (let ((package (find-package* package-designator error))) + (when package + (multiple-value-bind (symbol status) (find-symbol* name package error) + (cond + (status (unintern symbol package) + (return (values symbol status))) + (error (error "symbol ~A not present in package ~A" + (string symbol) (package-name package)))))) + (values nil nil)))) + (defun symbol-shadowing-p (symbol package) + (and (member symbol (package-shadowing-symbols package)) t)) + (defun home-package-p (symbol package) + (and package (let ((sp (symbol-package symbol))) + (and sp (let ((pp (find-package* package))) + (and pp (eq sp pp)))))))) -(in-package :asdf) (eval-when (:load-toplevel :compile-toplevel :execute) - ;;; This would belong amongst implementation-dependent tweaks above, - ;;; 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 + (defun symbol-package-name (symbol) + (let ((package (symbol-package symbol))) + (and package (package-name package)))) + (defun standard-common-lisp-symbol-p (symbol) + (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil) + (and (eq sym symbol) (eq status :external)))) + (defun reify-package (package &optional package-context) + (if (eq package package-context) t + (etypecase package + (null nil) + ((eql (find-package :cl)) :cl) + (package (package-name package))))) + (defun unreify-package (package &optional package-context) + (etypecase package + (null nil) + ((eql t) package-context) + ((or symbol string) (find-package package)))) + (defun reify-symbol (symbol &optional package-context) + (etypecase symbol + ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol) + (symbol (vector (symbol-name symbol) + (reify-package (symbol-package symbol) package-context))))) + (defun unreify-symbol (symbol &optional package-context) + (etypecase symbol + (symbol symbol) + ((simple-vector 2) + (let* ((symbol-name (svref symbol 0)) + (package-foo (svref symbol 1)) + (package (unreify-package package-foo package-context))) + (if package (intern* symbol-name package) + (make-symbol* symbol-name))))))) - ;;; Package setup, step 2. - (defvar *asdf-version* nil) - (defvar *upgraded-p* nil) - (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12. - (defun find-symbol* (s p) - (find-symbol (string s) p)) - ;; Strip out formatting that is not supported on Genera. - ;; Has to be inside the eval-when to make Lispworks happy (!) - (defun strcat (&rest strings) - (apply 'concatenate 'string strings)) - (defmacro compatfmt (format) - #-(or gcl genera) format - #+(or gcl genera) - (loop :for (unsupported . replacement) :in - (append - '(("~3i~_" . "")) - #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do - (loop :for found = (search unsupported format) :while found :do - (setf format (strcat (subseq format 0 found) replacement - (subseq format (+ found (length unsupported))))))) - format) - (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.26.6") - (existing-asdf (find-class 'component nil)) - (existing-version *asdf-version*) - (already-there (equal asdf-version existing-version))) - (unless (and existing-asdf already-there) - (when (and existing-asdf *asdf-verbose*) - (format *trace-output* - (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))) - (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 (present-symbols u)) - (loop :for p :in (package-used-by-list u) :do - (unuse-package u p)) - (delete-package u)))) - (ensure-exists (name nicknames use) - (let ((previous - (remove-duplicates - (mapcar #'find-package (cons name nicknames)) - :from-end t))) - ;; do away with packages with conflicting (nick)names - (map () #'unlink-package (cdr previous)) - ;; reuse previous package with same name - (let ((p (car previous))) - (cond - (p - (rename-package p name nicknames) - (ensure-use p use) - p) - (t - (make-package name :nicknames nicknames :use use)))))) - (intern* (symbol package) - (intern (string symbol) package)) - (remove-symbol (symbol package) - (let ((sym (find-symbol* symbol package))) - (when sym - #-cormanlisp (unexport sym package) - (unintern sym package) - sym))) - (ensure-unintern (package symbols) - (loop :with packages = (list-all-packages) - :for sym :in symbols - :for removed = (remove-symbol sym package) - :when removed :do - (loop :for p :in packages :do - (when (eq removed (find-symbol* sym p)) - (unintern removed p))))) - (ensure-shadow (package symbols) - (shadow symbols package)) - (ensure-use (package use) - (dolist (used (package-use-list package)) - (unless (member (package-name used) use :test 'string=) - (unuse-package used) - (do-external-symbols (sym used) - (when (eq sym (find-symbol* sym package)) - (remove-symbol sym package))))) - (dolist (used (reverse use)) - (do-external-symbols (sym used) - (unless (eq sym (find-symbol* sym package)) - (remove-symbol sym package))) - (use-package used package))) - (ensure-fmakunbound (package symbols) - (loop :for name :in symbols - :for sym = (find-symbol* name package) - :when sym :do (fmakunbound sym))) - (ensure-export (package export) - (let ((formerly-exported-symbols nil) - (bothly-exported-symbols nil) - (newly-exported-symbols nil)) - (do-external-symbols (sym package) - (if (member sym export :test 'string-equal) - (push sym bothly-exported-symbols) - (push sym formerly-exported-symbols))) - (loop :for sym :in export :do - (unless (member sym bothly-exported-symbols :test 'equal) - (push sym newly-exported-symbols))) - (loop :for user :in (package-used-by-list package) - :for shadowing = (package-shadowing-symbols user) :do - (loop :for new :in newly-exported-symbols - :for old = (find-symbol* new user) - :when (and old (not (member old shadowing))) - :do (unintern old user))) - (loop :for x :in newly-exported-symbols :do - (export (intern* x package))))) - (ensure-package (name &key nicknames use unintern - shadow export redefined-functions) - (let* ((p (ensure-exists name nicknames use))) - (ensure-unintern p unintern) - (ensure-shadow p shadow) - (ensure-export p export) - (ensure-fmakunbound p redefined-functions) - p))) - (macrolet - ((pkgdcl (name &key nicknames use export - redefined-functions unintern shadow) - `(ensure-package - ',name :nicknames ',nicknames :use ',use :export ',export - :shadow ',shadow - :unintern ',unintern - :redefined-functions ',redefined-functions))) - (pkgdcl - :asdf - :use (:common-lisp) - :redefined-functions - (#: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 - #:system-relative-pathname - #:inherit-source-registry #:process-source-registry - #:process-source-registry-directive - #:compile-file* #:source-file-type) - :unintern - (#:*asdf-revision* #:around #:asdf-method-combination - #:split #:make-collector #:do-dep #:do-one-dep - #:resolve-relative-location-component #:resolve-absolute-location-component - #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function - :export - (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command - #:system-definition-pathname #:with-system-definitions - #:search-for-system-definition #:find-component #:component-find-path - #:compile-system #:load-system #:load-systems - #:require-system #:test-system #:clear-system - #:operation #:compile-op #:load-op #:load-source-op #:test-op - #:feature #:version #:version-satisfies - #:upgrade-asdf - #:implementation-identifier #:implementation-type #:hostname - #:input-files #:output-files #:output-file #:perform - #:operation-done-p #:explain - - #:component #:source-file - #:c-source-file #:cl-source-file #:java-source-file - #:cl-source-file.cl #:cl-source-file.lsp - #:static-file - #:doc-file - #:html-file - #:text-file - #:source-file-type - #:module ; components - #:system - #:unix-dso - - #:module-components ; component accessors - #:module-components-by-name - #:component-pathname - #:component-relative-pathname - #:component-name - #:component-version - #:component-parent - #:component-property - #:component-system - #:component-depends-on - #:component-encoding - #:component-external-format - - #:system-description - #:system-long-description - #:system-author - #:system-maintainer - #:system-license - #:system-licence - #:system-source-file - #:system-source-directory - #:system-relative-pathname - #:map-systems - - #:operation-description - #:operation-on-warnings - #:operation-on-failure - #:component-visited-p - - #:*system-definition-search-functions* ; variables - #:*central-registry* - #:*compile-file-warnings-behaviour* - #:*compile-file-failure-behaviour* - #:*resolve-symlinks* - #:*load-system-operation* - #:*asdf-verbose* - #:*verbose-out* - - #:asdf-version - - #:operation-error #:compile-failed #:compile-warned #:compile-error - #:error-name - #:error-pathname - #:load-system-definition-error - #:error-component #:error-operation - #:system-definition-error - #:missing-component - #:missing-component-of-version - #:missing-dependency - #:missing-dependency-of-version - #:circular-dependency ; errors - #:duplicate-names - - #:try-recompiling - #:retry - #:accept ; restarts - #:coerce-entry-to-directory - #:remove-entry-from-registry - - #:*encoding-detection-hook* - #:*encoding-external-format-hook* - #:*default-encoding* - #:*utf-8-external-format* - - #:clear-configuration - #:*output-translations-parameter* - #:initialize-output-translations - #:disable-output-translations - #:clear-output-translations - #:ensure-output-translations - #:apply-output-translations - #:compile-file* - #:compile-file-pathname* - #:enable-asdf-binary-locations-compatibility - #:*default-source-registries* - #:*source-registry-parameter* - #:initialize-source-registry - #:compute-source-registry - #:clear-source-registry - #:ensure-source-registry - #:process-source-registry - #:system-registered-p #:registered-systems #:loaded-systems - #:resolve-location - #:asdf-message - #:user-output-translations-pathname - #:system-output-translations-pathname - #:user-output-translations-directory-pathname - #:system-output-translations-directory-pathname - #:user-source-registry - #:system-source-registry - #:user-source-registry-directory - #:system-source-registry-directory - - ;; Utilities: please use asdf-utils instead - #| - ;; #:aif #:it - ;; #:appendf #:orf - #:length=n-p - #:remove-keys #:remove-keyword - #: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-pathnames - #:getenv-absolute-directory #:getenv-absolute-directories - #:probe-file* - #:find-symbol* #:strcat - #:make-pathname-component-logical #:make-pathname-logical - #:merge-pathnames* #:coerce-pathname #:subpathname #:subpathname* - #:pathname-directory-pathname #:pathname-parent-directory-pathname - #:read-file-forms - #:resolve-symlinks #:truenamize - #:split-string - #:component-name-to-pathname-components - #:split-name-type - #:subdirectories #:directory-files - #:while-collecting - #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* - #:*wild-path* #:wilden - #:directorize-pathname-host-device|# - ))) - #+genera (import 'scl:boolean :asdf) - (setf *asdf-version* asdf-version - *upgraded-p* (if existing-version - (cons existing-version *upgraded-p*) - *upgraded-p*)))))) +(eval-when (:load-toplevel :compile-toplevel :execute) + (defvar *all-package-happiness* '()) + (defvar *all-package-fishiness* (list t)) + (defvar *package-fishiness* '()) + (defun flush-fishy () + (when *package-fishiness* + (if (null (rest *package-fishiness*)) + (push (first *package-fishiness*) *all-package-happiness*) + (push (nreverse *package-fishiness*) *all-package-fishiness*)) + (setf *package-fishiness* nil))) + (defun record-fishy (info) + ;;(format t "~&FISHY: ~S~%" info) + (push info *package-fishiness*)) + (defmacro when-package-fishiness (&body body) + `(when *all-package-fishiness* , at body)) + (defmacro note-package-fishiness (&rest info) + `(when-package-fishiness (record-fishy (list , at info))))) -;;;; ------------------------------------------------------------------------- -;;;; User-visible parameters -;;;; -(defvar *resolve-symlinks* t - "Determine whether or not ASDF resolves symlinks when defining systems. +(eval-when (:load-toplevel :compile-toplevel :execute) + #+(or clisp clozure) + (defun get-setf-function-symbol (symbol) + #+clisp (let ((sym (get symbol 'system::setf-function))) + (if sym (values sym :setf-function) + (let ((sym (get symbol 'system::setf-expander))) + (if sym (values sym :setf-expander) + (values nil nil))))) + #+clozure (gethash symbol ccl::%setf-function-names%)) + #+(or clisp clozure) + (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind) + #+clisp (assert (member kind '(:setf-function :setf-expander))) + #+clozure (assert (eq kind t)) + #+clisp + (cond + ((null new-setf-symbol) + (remprop symbol 'system::setf-function) + (remprop symbol 'system::setf-expander)) + ((eq kind :setf-function) + (setf (get symbol 'system::setf-function) new-setf-symbol)) + ((eq kind :setf-expander) + (setf (get symbol 'system::setf-expander) new-setf-symbol)) + (t (error "invalid kind of setf-function ~S for ~S to be set to ~S" + kind symbol new-setf-symbol))) + #+clozure + (progn + (gethash symbol ccl::%setf-function-names%) new-setf-symbol + (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol)) + #+(or clisp clozure) + (defun create-setf-function-symbol (symbol) + #+clisp (system::setf-symbol symbol) + #+clozure (ccl::construct-setf-function-name symbol)) + (defun set-dummy-symbol (symbol reason other-symbol) + (setf (get symbol 'dummy-symbol) (cons reason other-symbol))) + (defun make-dummy-symbol (symbol) + (let ((dummy (copy-symbol symbol))) + (set-dummy-symbol dummy 'replacing symbol) + (set-dummy-symbol symbol 'replaced-by dummy) + dummy)) + (defun dummy-symbol (symbol) + (get symbol 'dummy-symbol)) + (defun get-dummy-symbol (symbol) + (let ((existing (dummy-symbol symbol))) + (if existing (values (cdr existing) (car existing)) + (make-dummy-symbol symbol)))) + (defun nuke-symbol-in-package (symbol package-designator) + (let ((package (find-package* package-designator)) + (name (symbol-name symbol))) + (multiple-value-bind (sym stat) (find-symbol name package) + (when (and (member stat '(:internal :external)) (eq symbol sym)) + (if (symbol-shadowing-p symbol package) + (shadowing-import (get-dummy-symbol symbol) package) + (unintern symbol package)))))) + (defun nuke-symbol (symbol &optional (packages (list-all-packages))) + #+(or clisp clozure) + (multiple-value-bind (setf-symbol kind) + (get-setf-function-symbol symbol) + (when kind (nuke-symbol setf-symbol))) + (loop :for p :in packages :do (nuke-symbol-in-package symbol p))) + (defun rehome-symbol (symbol package-designator) + "Changes the home package of a symbol, also leaving it present in its old home if any" + (let* ((name (symbol-name symbol)) + (package (find-package* package-designator)) + (old-package (symbol-package symbol)) + (old-status (and old-package (nth-value 1 (find-symbol name old-package)))) + (shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name)))) + (multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package) + (unless (eq package old-package) + (let ((overwritten-symbol-shadowing-p + (and overwritten-symbol-status + (symbol-shadowing-p overwritten-symbol package)))) + (note-package-fishiness + :rehome-symbol name (package-name old-package) + (package-name package) old-status (and shadowing t) + overwritten-symbol-status overwritten-symbol-shadowing-p) + (when old-package + (if shadowing + (shadowing-import shadowing old-package)) + (unintern symbol old-package)) + (cond + (overwritten-symbol-shadowing-p + (shadowing-import symbol package)) + (t + (when overwritten-symbol-status + (unintern overwritten-symbol package)) + (import symbol package))) + (if shadowing + (shadowing-import symbol old-package) + (import symbol old-package)) + #+(or clisp clozure) + (multiple-value-bind (setf-symbol kind) + (get-setf-function-symbol symbol) + (when kind + (let* ((setf-function (fdefinition setf-symbol)) + (new-setf-symbol (create-setf-function-symbol symbol))) + (note-package-fishiness + :setf-function + name (package-name package) + (symbol-name setf-symbol) (symbol-package-name setf-symbol) + (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol)) + (when (symbol-package setf-symbol) + (unintern setf-symbol (symbol-package setf-symbol))) + (setf (fdefinition new-setf-symbol) setf-function) + (set-setf-function-symbol new-setf-symbol symbol kind)))) + #+(or clisp clozure) + (multiple-value-bind (overwritten-setf foundp) + (get-setf-function-symbol overwritten-symbol) + (when foundp + (unintern overwritten-setf))) + (when (eq old-status :external) + (export* symbol old-package)) + (when (eq overwritten-symbol-status :external) + (export* symbol package)))) + (values overwritten-symbol overwritten-symbol-status)))) + (defun ensure-package-unused (package) + (loop :for p :in (package-used-by-list package) :do + (unuse-package package p))) + (defun delete-package* (package &key nuke) + (let ((p (find-package package))) + (when p + (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s)))) + (ensure-package-unused p) + (delete-package package)))) + (defun package-names (package) + (cons (package-name package) (package-nicknames package))) + (defun packages-from-names (names) + (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t)) + (defun fresh-package-name (&key (prefix :%TO-BE-DELETED) + separator + (index (random most-positive-fixnum))) + (loop :for i :from index + :for n = (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or separator "")) i) + :thereis (and (not (find-package n)) n))) + (defun rename-package-away (p &rest keys &key prefix &allow-other-keys) + (let ((new-name + (apply 'fresh-package-name + :prefix (or prefix (format nil "__~A__" (package-name p))) keys))) + (record-fishy (list :rename-away (package-names p) new-name)) + (rename-package p new-name)))) -Defaults to T.") -(defvar *compile-file-warnings-behaviour* - (or #+clisp :ignore :warn) - "How should ASDF react if it encounters a warning when compiling a file? -Valid values are :error, :warn, and :ignore.") +;;; Communicable representation of symbol and package information -(defvar *compile-file-failure-behaviour* - (or #+(or mkcl sbcl) :error #+clisp :ignore :warn) - "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE) -when compiling a file? Valid values are :error, :warn, and :ignore. -Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.") +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun package-definition-form (package-designator + &key (nicknamesp t) (usep t) + (shadowp t) (shadowing-import-p t) + (exportp t) (importp t) internp (error t)) + (let* ((package (or (find-package* package-designator error) + (return-from package-definition-form nil))) + (name (package-name package)) + (nicknames (package-nicknames package)) + (use (mapcar #'package-name (package-use-list package))) + (shadow ()) + (shadowing-import (make-hash-table :test 'equal)) + (import (make-hash-table :test 'equal)) + (export ()) + (intern ())) + (when package + (loop :for sym :being :the :symbols :in package + :for status = (nth-value 1 (find-symbol* sym package)) :do + (ecase status + ((nil :inherited)) + ((:internal :external) + (let* ((name (symbol-name sym)) + (external (eq status :external)) + (home (symbol-package sym)) + (home-name (package-name home)) + (imported (not (eq home package))) + (shadowing (symbol-shadowing-p sym package))) + (cond + ((and shadowing imported) + (push name (gethash home-name shadowing-import))) + (shadowing + (push name shadow)) + (imported + (push name (gethash home-name import)))) + (cond + (external + (push name export)) + (imported) + (t (push name intern))))))) + (labels ((sort-names (names) + (sort names #'string<)) + (table-keys (table) + (loop :for k :being :the :hash-keys :of table :collect k)) + (when-relevant (key value) + (when value (list (cons key value)))) + (import-options (key table) + (loop :for i :in (sort-names (table-keys table)) + :collect `(,key ,i ,@(sort-names (gethash i table)))))) + `(defpackage ,name + ,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames))) + (:use ,@(and usep (sort-names use))) + ,@(when-relevant :shadow (and shadowp (sort-names shadow))) + ,@(import-options :shadowing-import-from (and shadowing-import-p shadowing-import)) + ,@(import-options :import-from (and importp import)) + ,@(when-relevant :export (and exportp (sort-names export))) + ,@(when-relevant :intern (and internp (sort-names intern))))))))) -(defvar *verbose-out* nil) -(defparameter +asdf-methods+ - '(perform-with-restarts perform explain output-files operation-done-p)) +;;; ensure-package, define-package -(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.") +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun ensure-package (name &key + nicknames documentation use + shadow shadowing-import-from + import-from export intern + recycle mix reexport + unintern) + (declare (ignorable documentation)) + (macrolet ((when-fishy (&body body) `(when-package-fishiness , at body)) + (fishy (&rest info) `(note-package-fishiness , at info))) + (let* ((package-name (string name)) + (nicknames (mapcar #'string nicknames)) + (names (cons package-name nicknames)) + (previous (packages-from-names names)) + (discarded (cdr previous)) + (to-delete ()) + (package (or (first previous) (make-package package-name :nicknames nicknames))) + (recycle (packages-from-names recycle)) + (use (mapcar 'find-package* use)) + (mix (mapcar 'find-package* mix)) + (reexport (mapcar 'find-package* reexport)) + (shadow (mapcar 'string shadow)) + (export (mapcar 'string export)) + (intern (mapcar 'string intern)) + (unintern (mapcar 'string unintern)) + (shadowed (make-hash-table :test 'equal)) ; string to bool + (imported (make-hash-table :test 'equal)) ; string to bool + (exported (make-hash-table :test 'equal)) ; string to bool + ;; string to list home package and use package: + (inherited (make-hash-table :test 'equal))) + (when-fishy (record-fishy package-name)) + (labels + ((ensure-shadowing-import (name p) + (let ((import-me (find-symbol* name p))) + (multiple-value-bind (existing status) (find-symbol name package) + (cond + ((gethash name shadowed) + (unless (eq import-me existing) + (error "Conflicting shadowings for ~A" name))) + (t + (setf (gethash name shadowed) t) + (setf (gethash name imported) t) + (unless (or (null status) + (and (member status '(:internal :external)) + (eq existing import-me) + (symbol-shadowing-p existing package))) + (fishy :shadowing-import + name (package-name p) (symbol-package-name import-me) + (and status (symbol-package-name existing)) status)) + (shadowing-import import-me package)))))) + (ensure-import (sym p) + (let* ((name (string sym)) + (import-me (find-symbol* name p))) + (multiple-value-bind (existing status) (find-symbol name package) + (cond + ((gethash name imported) + (unless (eq import-me existing) + (error "Can't import ~S from both ~S and ~S" + name (package-name (symbol-package existing)) (package-name p)))) + ((gethash name shadowed) + (error "Can't both shadow ~S and import it from ~S" name (package-name p))) + (t + (setf (gethash name imported) t) + (unless (and status (eq import-me existing)) + (when status + (fishy :import name (package-name p) (symbol-package-name import-me) + (and status (symbol-package-name existing)) status) + (unintern* existing package)) + (import import-me package))))))) + (ensure-mix (name symbol p) + (unless (gethash name shadowed) + (multiple-value-bind (existing status) (find-symbol name package) + (let* ((sp (symbol-package symbol)) + (im (gethash name imported)) + (in (gethash name inherited))) + (cond + ((or (null status) + (and status (eq symbol existing)) + (and in (eq sp (first in)))) + (ensure-inherited name symbol p t)) + (in + (remhash name inherited) + (ensure-shadowing-import name (second in))) + (im + (error "Imported symbol ~S conflicts with inherited symbol ~S in ~S" + existing symbol (package-name package))) + (t + (ensure-inherited name symbol p t))))))) + (ensure-inherited (name symbol p mix) + (multiple-value-bind (existing status) (find-symbol name package) + (let* ((sp (symbol-package symbol)) + (in (gethash name inherited)) + (xp (and status (symbol-package existing)))) + (when (null sp) + (fishy :import-uninterned name (package-name p) mix) + (import symbol p) + (setf sp (package-name p))) + (cond + ((gethash name shadowed)) + (in + (unless (equal sp (first in)) + (if mix + (ensure-shadowing-import name (second in)) + (error "Can't inherit ~S from ~S, it is inherited from ~S" + name (package-name sp) (package-name (first in)))))) + ((gethash name imported) + (unless (eq symbol existing) + (error "Can't inherit ~S from ~S, it is imported from ~S" + name (package-name sp) (package-name xp)))) + (t + (setf (gethash name inherited) (list sp p)) + (when (and status (not (eq sp xp))) + (let ((shadowing (symbol-shadowing-p existing package))) + (fishy :inherited name (package-name p) (package-name sp) + (package-name xp)) + (if shadowing (ensure-shadowing-import name p) + (unintern* existing package))))))))) + (recycle-symbol (name) + (when (gethash name exported) ;; don't bother recycling private symbols + (let (recycled foundp) + (dolist (r recycle (values recycled foundp)) + (multiple-value-bind (symbol status) (find-symbol name r) + (when (and status (home-package-p symbol r)) + (cond + (foundp + ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that. + (fishy :recycled-duplicate name (package-name foundp) (package-name r))) + (t + (setf recycled symbol foundp r))))))))) + (symbol-recycled-p (sym) + (member (symbol-package sym) recycle)) + (ensure-symbol (name &optional intern) + (unless (or (gethash name shadowed) + (gethash name imported) + (gethash name inherited)) + (multiple-value-bind (existing status) + (find-symbol name package) + (multiple-value-bind (recycled previous) (recycle-symbol name) + (cond + ((and status (eq existing recycled) (eq previous package))) + (previous + (rehome-symbol recycled package)) + ((and status (eq package (symbol-package existing)))) + (t + (when status + (fishy :ensure-symbol name + (reify-package (symbol-package existing) package) + status intern) + (unintern existing)) + (when intern + (intern* name package)))))))) + (ensure-export (name p) + (multiple-value-bind (symbol status) (find-symbol* name p) + (unless (eq status :external) + (ensure-exported name symbol p)))) + (ensure-exported (name sym p) + (dolist (u (package-used-by-list p)) + (ensure-exported-to-user name sym u)) + (export* sym p)) + (ensure-exported-to-user (name sym u) + (multiple-value-bind (usym ustat) (find-symbol name u) + (unless (and ustat (eq sym usym)) + (let ((accessible + (or (null ustat) + (let ((shadowing (symbol-shadowing-p usym u)) + (recycled (symbol-recycled-p usym))) + (unless (and shadowing (not recycled)) + (fishy :ensure-export name (symbol-package-name sym) + (package-name u) + (and ustat (symbol-package-name usym)) ustat shadowing) + (if (or (eq ustat :inherited) shadowing) + (shadowing-import sym u) + (unintern usym u)) + t))))) + (when (and accessible (eq ustat :external)) + (ensure-exported name sym u))))))) + #-(or gcl genera) (setf (documentation package t) documentation) #+gcl documentation + (loop :for p :in (set-difference (package-use-list package) (append mix use)) + :do (fishy :use (package-names p)) (unuse-package p package)) + (loop :for p :in discarded + :for n = (remove-if #'(lambda (x) (member x names :test 'equal)) + (package-names p)) + :do (fishy :nickname (package-names p)) + (cond (n (rename-package p (first n) (rest n))) + (t (rename-package-away p) + (push p to-delete)))) + (rename-package package package-name nicknames) + (dolist (name unintern) + (multiple-value-bind (existing status) (find-symbol name package) + (when status + (unless (eq status :inherited) + (fishy :unintern name (symbol-package-name existing) status) + (unintern* name package nil))))) + (dolist (name export) + (setf (gethash name exported) t)) + (dolist (p reexport) + (do-external-symbols (sym p) + (setf (gethash (string sym) exported) t))) + (do-external-symbols (sym package) + (let ((name (symbol-name sym))) + (unless (gethash name exported) + (fishy :over-exported name (symbol-package-name sym)) + (unexport sym package)))) + (dolist (name shadow) + (setf (gethash name shadowed) t) + (multiple-value-bind (existing status) (find-symbol name package) + (multiple-value-bind (recycled previous) (recycle-symbol name) + (let ((shadowing (and status (symbol-shadowing-p existing package)))) + (cond + ((eq previous package)) + (previous + (rehome-symbol recycled package)) + ((or (member status '(nil :inherited)) + (home-package-p existing package))) + (t + (let ((dummy (make-symbol name))) + (fishy :shadow-imported name (symbol-package-name existing) status shadowing) + (shadowing-import dummy package) + (import dummy package))))))) + (shadow name package)) + (loop :for (p . syms) :in shadowing-import-from + :for pp = (find-package* p) :do + (dolist (sym syms) (ensure-shadowing-import (string sym) pp))) + (dolist (p mix) + (do-external-symbols (sym p) (ensure-mix (symbol-name sym) sym p))) + (loop :for (p . syms) :in import-from :do + (dolist (sym syms) (ensure-import sym p))) + (dolist (p (append use mix)) + (do-external-symbols (sym p) (ensure-inherited (string sym) sym p nil)) + (use-package p package)) + (loop :for name :being :the :hash-keys :of exported :do + (ensure-symbol name t) + (ensure-export name package)) + (dolist (name intern) + (ensure-symbol name t)) + (do-symbols (sym package) + (ensure-symbol (symbol-name sym))) + (map () 'delete-package* to-delete) + (flush-fishy) + package))))) + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun parse-define-package-form (package clauses) + (loop + :with use-p = nil :with recycle-p = nil + :with documentation = nil + :for (kw . args) :in clauses + :when (eq kw :nicknames) :append args :into nicknames :else + :when (eq kw :documentation) + :do (cond + (documentation (error "define-package: can't define documentation twice")) + ((or (atom args) (cdr args)) (error "define-package: bad documentation")) + (t (setf documentation (car args)))) :else + :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else + :when (eq kw :shadow) :append args :into shadow :else + :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else + :when (eq kw :import-from) :collect args :into import-from :else + :when (eq kw :export) :append args :into export :else + :when (eq kw :intern) :append args :into intern :else + :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else + :when (eq kw :mix) :append args :into mix :else + :when (eq kw :reexport) :append args :into reexport :else + :when (eq kw :unintern) :append args :into unintern :else + :do (error "unrecognized define-package keyword ~S" kw) + :finally (return `(,package + :nicknames ,nicknames :documentation ,documentation + :use ,(if use-p use '(:common-lisp)) + :shadow ,shadow :shadowing-import-from ,shadowing-import-from + :import-from ,import-from :export ,export :intern ,intern + :recycle ,(if recycle-p recycle (cons package nicknames)) + :mix ,mix :reexport ,reexport :unintern ,unintern))))) + +(defmacro define-package (package &rest clauses) + (let ((ensure-form + `(apply 'ensure-package ',(parse-define-package-form package clauses)))) + `(progn + #+clisp + (eval-when (:compile-toplevel :load-toplevel :execute) + ,ensure-form) + #+(or clisp ecl gcl) (defpackage ,package (:use)) + (eval-when (:compile-toplevel :load-toplevel :execute) + ,ensure-form)))) + +;;;; Final tricks to keep various implementations happy. +;; We want most such tricks in common-lisp.lisp, +;; but these need to be done before the define-package form there, +;; that we nevertheless want to be the very first form. +(eval-when (:load-toplevel :compile-toplevel :execute) + #+allegro ;; We need to disable autoloading BEFORE any mention of package ASDF. + (setf excl::*autoload-package-name-alist* + (remove "asdf" excl::*autoload-package-name-alist* + :test 'equalp :key 'car)) + + #+gcl + ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, + ;; but can run ASDF 2.011. GCL 2.6 has even more issues. + (cond + ((or (< system::*gcl-major-version* 2) + (and (= system::*gcl-major-version* 2) + (< system::*gcl-minor-version* 6))) + (error "GCL 2.6 or later required to use ASDF")) + ((and (= system::*gcl-major-version* 2) + (= system::*gcl-minor-version* 6)) + (pushnew 'ignorable pcl::*variable-declarations-without-argument*) + (pushnew :gcl2.6 *features*)) + (t + (pushnew :gcl2.7 *features*)))) +;;;; ------------------------------------------------------------------------- +;;;; Handle compatibility with multiple implementations. +;;; This file is for papering over the deficiencies and peculiarities +;;; of various Common Lisp implementations. +;;; For implementation-specific access to the system, see os.lisp instead. +;;; A few functions are defined here, but actually exported from utility; +;;; from this package only common-lisp symbols are exported. + +(asdf/package:define-package :asdf/common-lisp + (:nicknames :asdf/cl) + (:use #-genera :common-lisp #+genera :future-common-lisp :asdf/package) + (:reexport :common-lisp) + (:recycle :asdf/common-lisp :asdf) + #+allegro (:intern #:*acl-warn-save*) + #+cormanlisp + (:export + #:logical-pathname #:translate-logical-pathname + #:make-broadcast-stream #:file-namestring) + #+gcl2.6 (:shadow #:type-of #:with-standard-io-syntax) ; causes errors when loading fasl(!) + #+gcl2.6 (:shadowing-import-from :system #:*load-pathname*) + #+genera (:shadowing-import-from :scl #:boolean) + #+genera (:export #:boolean #:ensure-directories-exist) + #+mcl (:shadow #:user-homedir-pathname)) +(in-package :asdf/common-lisp) + +#-(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.") -(defvar *compile-op-compile-file-function* 'compile-file* - "Function used to compile lisp files.") +;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults. +;;;; Early meta-level tweaks + +#+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode) + clozure lispworks (and sbcl sb-unicode) scl) +(eval-when (:load-toplevel :compile-toplevel :execute) + (pushnew :asdf-unicode *features*)) #+allegro -(eval-when (:compile-toplevel :execute) +(eval-when (:load-toplevel :compile-toplevel :execute) (defparameter *acl-warn-save* - (when (boundp 'excl:*warn-on-nested-reader-conditionals*) - excl:*warn-on-nested-reader-conditionals*)) + (when (boundp 'excl:*warn-on-nested-reader-conditionals*) + excl:*warn-on-nested-reader-conditionals*)) (when (boundp 'excl:*warn-on-nested-reader-conditionals*) - (setf excl:*warn-on-nested-reader-conditionals* nil))) + (setf excl:*warn-on-nested-reader-conditionals* nil)) + (setf *print-readably* nil)) -;;;; ------------------------------------------------------------------------- -;;;; Resolve forward references - -(declaim (ftype (function (t) t) - format-arguments format-control - error-name error-pathname error-condition - duplicate-names-name - error-component error-operation - module-components module-components-by-name - circular-dependency-components - condition-arguments condition-form - condition-format condition-location - coerce-name) - (ftype (function (&optional t) (values)) initialize-source-registry) - #-(or cormanlisp gcl-pre2.7) - (ftype (function (t t) t) (setf module-components-by-name))) - -;;;; ------------------------------------------------------------------------- -;;;; Compatibility various implementations #+cormanlisp (progn (deftype logical-pathname () nil) @@ -467,6 +778,60 @@ (setf p (pathname p)) (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) +#+ecl +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf *load-verbose* nil) + (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t)) + (unless (use-ecl-byte-compiler-p) (require :cmp))) + +#+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011 +(eval-when (:load-toplevel :compile-toplevel :execute) + (unless (member :ansi-cl *features*) + (error "ASDF only supports GCL in ANSI mode. Aborting.~%")) + (setf compiler::*compiler-default-type* (pathname "") + compiler::*lsp-ext* "")) + +#+gcl2.6 +(eval-when (:compile-toplevel :load-toplevel :execute) + (shadow 'type-of :asdf/common-lisp) + (shadowing-import 'system:*load-pathname* :asdf/common-lisp)) + +#+gcl2.6 +(eval-when (:compile-toplevel :load-toplevel :execute) + (export 'type-of :asdf/common-lisp) + (export 'system:*load-pathname* :asdf/common-lisp)) + +#+gcl2.6 +(progn ;; Doesn't support either logical-pathnames or output-translations. + (defvar *gcl2.6* t) + (deftype logical-pathname () nil) + (defun type-of (x) (class-name (class-of x))) + (defun wild-pathname-p (path) (declare (ignore path)) nil) + (defun translate-logical-pathname (x) x) + (defvar *compile-file-pathname* nil) + (defun pathname-match-p (in-pathname wild-pathname) + (declare (ignore in-wildname wild-wildname)) nil) + (defun translate-pathname (source from-wildname to-wildname &key) + (declare (ignore from-wildname to-wildname)) source) + (defun %print-unreadable-object (object stream type identity thunk) + (format stream "#<~@[~S ~]" (when type (type-of object))) + (funcall thunk) + (format stream "~@[ ~X~]>" (when identity (system:address object)))) + (defmacro with-standard-io-syntax (&body body) + `(progn , at body)) + (defmacro with-compilation-unit (options &body body) + (declare (ignore options)) `(progn , at body)) + (defmacro print-unreadable-object ((object stream &key type identity) &body body) + `(%print-unreadable-object ,object ,stream ,type ,identity (lambda () , at body))) + (defun ensure-directories-exist (path) + (lisp:system (format nil "mkdir -p ~S" + (namestring (make-pathname :name nil :type nil :version nil :defaults path)))))) + +#+genera +(unless (fboundp 'ensure-directories-exist) + (defun ensure-directories-exist (path) + (fs:create-directories-recursively (pathname path)))) + #.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl (read-from-string "(eval-when (:compile-toplevel :load-toplevel :execute) @@ -476,7 +841,7 @@ ;; the pathname of the current user's home directory, whereas ;; MCL by default provides the directory from which MCL was started. ;; See http://code.google.com/p/mcl/wiki/Portability - (defun current-user-homedir-pathname () + (defun user-homedir-pathname () (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType)) (defun probe-posix (posix-namestring) \"If a file exists for the posix namestring, return the pathname\" @@ -486,21 +851,144 @@ (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir)) (ccl::%path-from-fsref fsref is-dir))))))")) +#+mkcl +(eval-when (:load-toplevel :compile-toplevel :execute) + (require :cmp) + (setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict ANSI class redefinition semantics + + +;;;; compatfmt: avoid fancy format directives when unsupported + +(defmacro loop* (&rest rest) + #-genera `(loop , at rest) + #+genera `(lisp:loop , at rest)) ;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh. + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun strcat (&rest strings) + (apply 'concatenate 'string strings))) + +(defmacro compatfmt (format) + #+(or gcl genera) + (loop* :for (unsupported . replacement) + :in (append + '(("~3i~_" . "")) + #+(or genera gcl2.6) '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do + (loop :for found = (search unsupported format) :while found :do + (setf format (strcat (subseq format 0 found) replacement + (subseq format (+ found (length unsupported))))))) + format) ;;;; ------------------------------------------------------------------------- -;;;; General Purpose Utilities +;;;; General Purpose Utilities for ASDF + +(asdf/package:define-package :asdf/utility + (:recycle :asdf/utility :asdf) + (:use :asdf/common-lisp :asdf/package) + ;; import and reexport a few things defined in :asdf/common-lisp + (:import-from :asdf/common-lisp #:strcat #:compatfmt #:loop* + #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix) + (:export #:nil #:strcat #:compatfmt #:loop* + #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix) + (:export + ;; magic helper to define debugging functions: + #:asdf-debug #:load-asdf-debug-utility #:*asdf-debug-utility* + #:undefine-function #:undefine-functions #:defun* #:defgeneric* ;; (un)defining functions + #:if-let ;; basic flow control + #:while-collecting #:appendf #:length=n-p #:remove-plist-keys #:remove-plist-key ;; lists and plists + #:emptyp ;; sequences + #:first-char #:last-char #:split-string ;; strings + #:string-prefix-p #:string-enclosed-p #:string-suffix-p + #:find-class* ;; CLOS + #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps + #:earlier-stamp #:stamps-earliest #:earliest-stamp + #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f + #:list-to-hash-set ;; hash-table + #:ensure-function #:access-at #:access-at-count ;; functions + #:call-function #:call-functions #:register-hook-function + #:match-condition-p #:match-any-condition-p ;; conditions + #:call-with-muffled-conditions #:with-muffled-conditions + #:load-string #:load-stream + #:parse-version #:unparse-version #:version-compatible-p)) ;; version +(in-package :asdf/utility) + +;;;; Defining functions in a way compatible with hot-upgrade: +;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefinition, +;; thus replacing the function without warning or error +;; even if the signature and/or generic-ness of the function has changed. +;; For a generic function, this invalidates any previous DEFMETHOD. +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun undefine-function (function-spec) + (cond + ((symbolp function-spec) + #+clisp + (let ((f (and (fboundp function-spec) (fdefinition function-spec)))) + (when (typep f 'clos:standard-generic-function) + (loop :for m :in (clos:generic-function-methods f) + :do (remove-method f m)))) + (fmakunbound function-spec)) + ((and (consp function-spec) (eq (car function-spec) 'setf) + (consp (cdr function-spec)) (null (cddr function-spec))) + #-gcl2.6 (fmakunbound function-spec)) + (t (error "bad function spec ~S" function-spec)))) + (defun undefine-functions (function-spec-list) + (map () 'undefine-function function-spec-list))) (macrolet ((defdef (def* def) `(defmacro ,def* (name formals &rest rest) - `(progn - #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name) - #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-( - ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl - `(declaim (notinline ,name))) - (,',def ,name ,formals , at rest))))) + (destructuring-bind (name &key (supersede t)) + (if (or (atom name) (eq (car name) 'setf)) + (list name :supersede nil) + name) + (declare (ignorable supersede)) + `(progn + ;; undefining the previous function is the portable way + ;; of overriding any incompatible previous gf, except on CLISP. + ;; We usually try to do it only for the functions that need it, + ;; which happens in asdf/upgrade - however, for ECL, we need this hammer, + ;; (which causes issues in clisp) + ,@(when (or #-clisp supersede #+(or ecl gcl2.7) t) ; XXX + `((undefine-function ',name))) + #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-( + ,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl + `((declaim (notinline ,name)))) + (,',def ,name ,formals , at rest)))))) (defdef defgeneric* defgeneric) (defdef defun* defun)) + +;;; Magic debugging help. See contrib/debug.lisp +(defvar *asdf-debug-utility* + '(ignore-errors (merge-pathnames "cl/asdf/contrib/debug.lisp" (user-homedir-pathname))) + "form that evaluates to the pathname to your favorite debugging utilities") + +(defmacro asdf-debug (&rest keys) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (load-asdf-debug-utility , at keys))) + +(defun* load-asdf-debug-utility (&key package utility-file) + (let* ((*package* (if package (find-package package) *package*)) + (keyword (read-from-string + (format nil ":DBG-~:@(~A~)" (package-name *package*))))) + (unless (member keyword *features*) + (let* ((utility-file (or utility-file *asdf-debug-utility*)) + (file (ignore-errors (probe-file (eval utility-file))))) + (if file (load file) + (error "Failed to locate debug utility file: ~S" utility-file)))))) + + +;;; Flow control +(defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria + ;; bindings can be (var form) or ((var1 form1) ...) + (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings))) + (list bindings) + bindings)) + (variables (mapcar #'car binding-list))) + `(let ,binding-list + (if (and , at variables) + ,then-form + ,else-form)))) + +;;; List manipulation (defmacro while-collecting ((&rest collectors) &body body) "COLLECTORS should be a list of names for collections. A collector defines a function that, when applied to an argument inside BODY, will @@ -519,30 +1007,378 @@ , at body (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) -(defmacro aif (test then &optional else) - "Anaphoric version of IF, On Lisp style" - `(let ((it ,test)) (if it ,then ,else))) +(define-modify-macro appendf (&rest args) + append "Append onto list") ;; only to be used on short lists. + +(defun* length=n-p (x n) ;is it that (= (length x) n) ? + (check-type n (integer 0 *)) + (loop + :for l = x :then (cdr l) + :for i :downfrom n :do + (cond + ((zerop i) (return (null l))) + ((not (consp l)) (return nil))))) + +;;; remove a key from a plist, i.e. for keyword argument cleanup +(defun* remove-plist-key (key plist) + "Remove a single key from a plist" + (loop* :for (k v) :on plist :by #'cddr + :unless (eq k key) + :append (list k v))) + +(defun* remove-plist-keys (keys plist) + "Remove a list of keys from a plist" + (loop* :for (k v) :on plist :by #'cddr + :unless (member k keys) + :append (list k v))) + + +;;; Sequences +(defun* emptyp (x) + "Predicate that is true for an empty sequence" + (or (null x) (and (vectorp x) (zerop (length x))))) + + +;;; Strings + +(defun* first-char (s) + (and (stringp s) (plusp (length s)) (char s 0))) + +(defun* last-char (s) + (and (stringp s) (plusp (length s)) (char s (1- (length s))))) + +(defun* split-string (string &key max (separator '(#\Space #\Tab))) + "Split STRING into a list of components separated by +any of the characters in the sequence SEPARATOR. +If MAX is specified, then no more than max(1,MAX) components will be returned, +starting the separation from the end, e.g. when called with arguments + \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")." + (block () + (let ((list nil) (words 0) (end (length string))) + (flet ((separatorp (char) (find char separator)) + (done () (return (cons (subseq string 0 end) list)))) + (loop + :for start = (if (and max (>= words (1- max))) + (done) + (position-if #'separatorp string :end end :from-end t)) :do + (when (null start) + (done)) + (push (subseq string (1+ start) end) list) + (incf words) + (setf end start)))))) + +(defun* string-prefix-p (prefix string) + "Does STRING begin with PREFIX?" + (let* ((x (string prefix)) + (y (string string)) + (lx (length x)) + (ly (length y))) + (and (<= lx ly) (string= x y :end2 lx)))) + +(defun* string-suffix-p (string suffix) + "Does STRING end with SUFFIX?" + (let* ((x (string string)) + (y (string suffix)) + (lx (length x)) + (ly (length y))) + (and (<= ly lx) (string= x y :start1 (- lx ly))))) + +(defun* string-enclosed-p (prefix string suffix) + "Does STRING begin with PREFIX and end with SUFFIX?" + (and (string-prefix-p prefix string) + (string-suffix-p string suffix))) + + +;;; CLOS +(defun* find-class* (x &optional (errorp t) environment) + (etypecase x + ((or standard-class built-in-class) x) + #+gcl2.6 (keyword nil) + (symbol (find-class x errorp environment)))) + + +;;; stamps: a REAL or boolean where NIL=-infinity, T=+infinity +(deftype stamp () '(or real boolean)) +(defun* stamp< (x y) + (etypecase x + (null (and y t)) + ((eql t) nil) + (real (etypecase y + (null nil) + ((eql t) t) + (real (< x y)))))) +(defun* stamps< (list) (loop :for y :in list :for x = nil :then y :always (stamp< x y))) +(defun* stamp*< (&rest list) (stamps< list)) +(defun* stamp<= (x y) (not (stamp< y x))) +(defun* earlier-stamp (x y) (if (stamp< x y) x y)) +(defun* stamps-earliest (list) (reduce 'earlier-stamp list :initial-value t)) +(defun* earliest-stamp (&rest list) (stamps-earliest list)) +(defun* later-stamp (x y) (if (stamp< x y) y x)) +(defun* stamps-latest (list) (reduce 'later-stamp list :initial-value nil)) +(defun* latest-stamp (&rest list) (stamps-latest list)) +(define-modify-macro latest-stamp-f (&rest stamps) latest-stamp) + + +;;; Hash-tables +(defun* list-to-hash-set (list &aux (h (make-hash-table :test 'equal))) + (dolist (x list h) (setf (gethash x h) t))) + + +;;; Function designators +(defun* ensure-function (fun &key (package :cl)) + "Coerce the object FUN into a function. + +If FUN is a FUNCTION, return it. +If the FUN is a non-sequence literal constant, return constantly that, +i.e. for a boolean keyword character number or pathname. +Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION. +If FUN is a CONS, return the function that applies its CAR +to the appended list of the rest of its CDR and the arguments. +If FUN is a string, READ a form from it in the specified PACKAGE (default: CL) +and EVAL that in a (FUNCTION ...) context." + (etypecase fun + (function fun) + ((or boolean keyword character number pathname) (constantly fun)) + ((or function symbol) fun) + (cons #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args)))) + (string (eval `(function ,(with-standard-io-syntax + (let ((*package* (find-package package))) + (read-from-string fun)))))))) + +(defun* access-at (object at) + "Given an OBJECT and an AT specifier, list of successive accessors, +call each accessor on the result of the previous calls. +An accessor may be an integer, meaning a call to ELT, +a keyword, meaning a call to GETF, +NIL, meaning identity, +a function or other symbol, meaning itself, +or a list of a function designator and arguments, interpreted as per ENSURE-FUNCTION. +As a degenerate case, the AT specifier may be an atom of a single such accessor +instead of a list." + (flet ((access (object accessor) + (etypecase accessor + (function (funcall accessor object)) + (integer (elt object accessor)) + (keyword (getf object accessor)) + (null object) + (symbol (funcall accessor object)) + (cons (funcall (ensure-function accessor) object))))) + (if (listp at) + (dolist (accessor at object) + (setf object (access object accessor))) + (access object at)))) + +(defun* access-at-count (at) + "From an AT specification, extract a COUNT of maximum number + of sub-objects to read as per ACCESS-AT" + (cond + ((integerp at) + (1+ at)) + ((and (consp at) (integerp (first at))) + (1+ (first at))))) + +(defun* call-function (function-spec &rest arguments) + (apply (ensure-function function-spec) arguments)) + +(defun* call-functions (function-specs) + (map () 'call-function function-specs)) + +(defun* register-hook-function (variable hook &optional (call-now-p t)) + (pushnew hook (symbol-value variable)) + (when call-now-p (call-function hook))) + + +;;; Version handling +(defun* unparse-version (version-list) + (format nil "~{~D~^.~}" version-list)) + +(defun* parse-version (version-string &optional on-error) + "Parse a VERSION-STRING as a series of natural integers separated by dots. +Return a (non-null) list of integers if the string is valid; +otherwise return NIL. + +When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL, +with format arguments explaining why the version is invalid. +ON-ERROR is also called if the version is not canonical +in that it doesn't print back to itself, but the list is returned anyway." + (block nil + (unless (stringp version-string) + (call-function on-error "~S: ~S is not a string" 'parse-version version-string) + (return)) + (unless (loop :for prev = nil :then c :for c :across version-string + :always (or (digit-char-p c) + (and (eql c #\.) prev (not (eql prev #\.)))) + :finally (return (and c (digit-char-p c)))) + (call-function on-error "~S: ~S doesn't follow asdf version numbering convention" + 'parse-version version-string) + (return)) + (let* ((version-list + (mapcar #'parse-integer (split-string version-string :separator "."))) + (normalized-version (unparse-version version-list))) + (unless (equal version-string normalized-version) + (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string)) + version-list))) + + +(defun* version-compatible-p (provided-version required-version) + "Is the provided version a compatible substitution for the required-version? +If major versions differ, it's not compatible. +If they are equal, then any later version is compatible, +with later being determined by a lexicographical comparison of minor numbers." + (let ((x (parse-version provided-version 'warn)) + (y (parse-version required-version 'warn))) + (labels ((bigger (x y) + (cond ((not y) t) + ((not x) nil) + ((> (car x) (car y)) t) + ((= (car x) (car y)) + (bigger (cdr x) (cdr y)))))) + (and x y (= (car x) (car y)) + (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) -(defun* pathname-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 :defaults pathname))) + +;;; Condition control + +(defvar *uninteresting-conditions* nil + "Uninteresting conditions, as per MATCH-CONDITION-P") + +(defparameter +simple-condition-format-control-slot+ + #+abcl 'system::format-control + #+allegro 'excl::format-control + #+clisp 'system::$format-control + #+clozure 'ccl::format-control + #+ecl 'si::format-control + #+(or cmu scl) 'conditions::format-control + #+(or gcl lispworks) 'conditions::format-string + #+sbcl 'sb-kernel:format-control + #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) nil + "Name of the slot for FORMAT-CONTROL in simple-condition") + +(defun* match-condition-p (x condition) + "Compare received CONDITION to some pattern X: +a symbol naming a condition class, +a simple vector of length 2, arguments to find-symbol* with result as above, +or a string describing the format-control of a simple-condition." + (etypecase x + (symbol (typep condition x)) + ((simple-vector 2) (typep condition (find-symbol* (svref x 0) (svref x 1) nil))) + (function (funcall x condition)) + (string (and (typep condition 'simple-condition) + ;; On SBCL, it's always set and the check triggers a warning + #+(or allegro clozure cmu lispworks scl) + (slot-boundp condition +simple-condition-format-control-slot+) + (ignore-errors (equal (simple-condition-format-control condition) x)))))) + +(defun* match-any-condition-p (condition conditions) + "match CONDITION against any of the patterns of CONDITIONS supplied" + (loop :for x :in conditions :thereis (match-condition-p x condition))) + +(defun* call-with-muffled-conditions (thunk conditions) + (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions) + (muffle-warning c))))) + (funcall thunk))) + +(defmacro with-muffled-uninteresting-conditions ((conditions) &body body) + `(call-with-muffled-uninteresting-conditions #'(lambda () , at body) ,conditions)) + +;;;; ------------------------------------------------------------------------- +;;;; Portability layer around Common Lisp pathnames + +(asdf/package:define-package :asdf/pathname + (:recycle :asdf/pathname :asdf) + (:use :asdf/common-lisp :asdf/package :asdf/utility) + (:export + #:*resolve-symlinks* + ;; Making and merging pathnames, portably + #:normalize-pathname-directory-component #:denormalize-pathname-directory-component + #:pathname-equal + #:merge-pathname-directory-components #:make-pathname* #:*unspecific-pathname-type* + #:make-pathname-component-logical #:make-pathname-logical + #:merge-pathnames* + ;; Directories + #:pathname-directory-pathname #:pathname-parent-directory-pathname + #:directory-pathname-p #:ensure-directory-pathname #:file-pathname-p + ;; Absolute vs relative pathnames + #:ensure-pathname-absolute + #:relativize-directory-component #:relativize-pathname-directory + ;; Parsing filenames and lists thereof + #:component-name-to-pathname-components + #:split-name-type #:parse-unix-namestring #:unix-namestring + #:split-unix-namestring-directory-components + #:subpathname #:subpathname* #:subpathp + ;; Resolving symlinks somewhat + #:truenamize #:resolve-symlinks #:resolve-symlinks* + ;; Wildcard pathnames + #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden + ;; Pathname host and its root + #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p + #:pathname-root #:directory-separator-for-host + #:directorize-pathname-host-device + ;; defaults + #:nil-pathname #:with-pathname-defaults + ;; probe filesystem + #:truename* #:probe-file* #:safe-file-write-date + #:subdirectories #:directory-files #:directory* + #:filter-logical-directory-results #:collect-sub*directories + ;; Simple filesystem operations + #:ensure-all-directories-exist + #:rename-file-overwriting-target + #:delete-file-if-exists + ;; Translate a pathname + #:translate-pathname* + ;; temporary + #:add-pathname-suffix #:tmpize-pathname + #:call-with-staging-pathname #:with-staging-pathname + ;; physical pathnames + #:logical-pathname-p #:physical-pathname-p #:sane-physical-pathname #:root-pathname + ;; Windows shortcut support + #:read-null-terminated-string #:read-little-endian + #:parse-file-location-info #:parse-windows-shortcut + ;; Checking constraints + #:ensure-pathname + #:absolutize-pathnames + ;; Output translations + #:*output-translation-function*)) + +(in-package :asdf/pathname) + +;;; User-visible parameters +(defvar *resolve-symlinks* t + "Determine whether or not ASDF resolves symlinks when defining systems. + +Defaults to T.") + + +;;; Normalizing pathnames across implementations (defun* normalize-pathname-directory-component (directory) "Given a pathname directory component, return an equivalent form that is a list" + #+gcl2.6 (setf directory (substitute :back :parent directory)) (cond #-(or cmu sbcl scl) ;; these implementations already normalize directory components. - ((stringp directory) `(:absolute ,directory) directory) - #+gcl - ((and (consp directory) (stringp (first directory))) - `(:absolute , at directory)) + ((stringp directory) `(:absolute ,directory)) + #+gcl2.6 + ((and (consp directory) (eq :root (first directory))) + `(:absolute ,@(rest directory))) ((or (null directory) (and (consp directory) (member (first directory) '(:absolute :relative)))) directory) + #+gcl2.6 + ((consp directory) + `(:relative , at directory)) (t (error (compatfmt "~@") directory)))) +(defun* denormalize-pathname-directory-component (directory-component) + #-gcl2.6 directory-component + #+gcl2.6 + (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back))) + directory-component))) + (cond + ((and (consp d) (eq :relative (first d))) (rest d)) + ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d))) + (t d)))) + (defun* merge-pathname-directory-components (specified defaults) ;; Helper for merge-pathnames* that handles directory components. (let ((directory (normalize-pathname-directory-component specified))) @@ -566,6 +1402,27 @@ :do (pop reldir) (pop defrev) :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) +;; Giving :unspecific as :type argument to make-pathname is not portable. +;; See CLHS make-pathname and 19.2.2.2.3. +;; This will be :unspecific if supported, or NIL if not. +(defparameter *unspecific-pathname-type* + #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific + #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil) + +(defun* make-pathname* (&rest keys &key (directory nil directoryp) + host (device () devicep) name type version defaults + #+scl &allow-other-keys) + "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and + tries hard to make a pathname that will actually behave as documented, + despite the peculiarities of each implementation" + (declare (ignorable host device devicep name type version defaults)) + (apply 'make-pathname + (append + #+allegro (when (and devicep (null device)) `(:device :unspecific)) + (when directoryp + `(:directory ,(denormalize-pathname-directory-component directory))) + keys))) + (defun* make-pathname-component-logical (x) "Make a pathname component suitable for use in a logical-pathname" (typecase x @@ -577,20 +1434,83 @@ (defun* make-pathname-logical (pathname host) "Take a PATHNAME's directory, name, type and version components, and make a new pathname with corresponding components and specified logical HOST" - (make-pathname + (make-pathname* :host host :directory (make-pathname-component-logical (pathname-directory pathname)) :name (make-pathname-component-logical (pathname-name pathname)) :type (make-pathname-component-logical (pathname-type pathname)) :version (make-pathname-component-logical (pathname-version pathname)))) + +;;; Some pathname predicates + +(defun* pathname-equal (p1 p2) + (when (stringp p1) (setf p1 (pathname p1))) + (when (stringp p2) (setf p2 (pathname p2))) + (flet ((normalize-component (x) + (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal) + x))) + (macrolet ((=? (&rest accessors) + (flet ((frob (x) + (reduce 'list (cons 'normalize-component accessors) + :initial-value x :from-end t))) + `(equal ,(frob 'p1) ,(frob 'p2))))) + (or (and (null p1) (null p2)) + (and (pathnamep p1) (pathnamep p2) + (and (=? pathname-host) + (=? pathname-device) + (=? normalize-pathname-directory-component pathname-directory) + (=? pathname-name) + (=? pathname-type) + (=? pathname-version))))))) + +(defun* logical-pathname-p (x) + (typep x 'logical-pathname)) + +(defun* physical-pathname-p (x) + (and (pathnamep x) (not (logical-pathname-p x)))) + +(defun* absolute-pathname-p (pathspec) + "If PATHSPEC is a pathname or namestring object that parses as a pathname +possessing an :ABSOLUTE directory component, return the (parsed) pathname. +Otherwise return NIL" + (and pathspec + (typep pathspec '(or null pathname string)) + (let ((pathname (pathname pathspec))) + (and (eq :absolute (car (normalize-pathname-directory-component + (pathname-directory pathname)))) + pathname)))) + +(defun* relative-pathname-p (pathspec) + "If PATHSPEC is a pathname or namestring object that parses as a pathname +possessing a :RELATIVE or NIL directory component, return the (parsed) pathname. +Otherwise return NIL" + (and pathspec + (typep pathspec '(or null pathname string)) + (let* ((pathname (pathname pathspec)) + (directory (normalize-pathname-directory-component + (pathname-directory pathname)))) + (when (or (null directory) (eq :relative (car directory))) + pathname)))) + +(defun* hidden-pathname-p (pathname) + "Return a boolean that is true if the pathname is hidden as per Unix style, +i.e. its name starts with a dot." + (and pathname (equal (first-char (pathname-name pathname)) #\.))) + + +;;;; merging pathnames (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 both come from the DEFAULTS, whereas if the SPECIFIED pathname does have an absolute directory, then the HOST and DEVICE both come from the SPECIFIED. -Also, if either argument is NIL, then the other argument is returned unmodified." +This is what users want on a modern Unix or Windows operating system, +unlike the MERGE-PATHNAME behavior. +Also, if either argument is NIL, then the other argument is returned unmodified; +this is unlike MERGE-PATHNAME which always merges with a pathname, +by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL." (when (null specified) (return-from merge-pathnames* defaults)) (when (null defaults) (return-from merge-pathnames* specified)) #+scl @@ -603,7 +1523,7 @@ (type (or (pathname-type specified) (pathname-type defaults))) (version (or (pathname-version specified) (pathname-version defaults)))) (labels ((unspecific-handler (p) - (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity))) + (if (logical-pathname-p p) #'make-pathname-component-logical #'identity))) (multiple-value-bind (host device directory unspecific-handler) (ecase (first directory) ((:absolute) @@ -616,166 +1536,59 @@ (pathname-device defaults) (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)))))) + (make-pathname* :host host :device device :directory directory + :name (funcall unspecific-handler name) + :type (funcall unspecific-handler type) + :version (funcall unspecific-handler version)))))) + +;;; Directories +(defun* pathname-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 :defaults pathname))) (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))) + (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. +(defun* directory-pathname-p (pathname) + "Does PATHNAME represent a directory? -(define-modify-macro orf (&rest args) - or "or a flag") +A directory-pathname is a pathname _without_ a filename. The three +ways that the filename components can be missing are for it to be NIL, +:UNSPECIFIC or the empty string. -(defun* first-char (s) - (and (stringp s) (plusp (length s)) (char s 0))) +Note that this does _not_ check to see that PATHNAME points to an +actually-existing directory." + (when pathname + (let ((pathname (pathname pathname))) + (flet ((check-one (x) + (member x '(nil :unspecific "") :test 'equal))) + (and (not (wild-pathname-p pathname)) + (check-one (pathname-name pathname)) + (check-one (pathname-type pathname)) + t))))) -(defun* last-char (s) - (and (stringp s) (plusp (length s)) (char s (1- (length s))))) +(defun* file-pathname-p (pathname) + "Does PATHNAME represent a file, i.e. has a non-null NAME component? +Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME. -(defun* asdf-message (format-string &rest format-args) - (declare (dynamic-extent format-args)) - (apply 'format *verbose-out* format-string format-args)) +Note that this does _not_ check to see that PATHNAME points to an +actually-existing file. -(defun* split-string (string &key max (separator '(#\Space #\Tab))) - "Split STRING into a list of components separated by -any of the characters in the sequence SEPARATOR. -If MAX is specified, then no more than max(1,MAX) components will be returned, -starting the separation from the end, e.g. when called with arguments - \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")." - (catch nil - (let ((list nil) (words 0) (end (length string))) - (flet ((separatorp (char) (find char separator)) - (done () (throw nil (cons (subseq string 0 end) list)))) - (loop - :for start = (if (and max (>= words (1- max))) - (done) - (position-if #'separatorp string :end end :from-end t)) :do - (when (null start) - (done)) - (push (subseq string (1+ start) end) list) - (incf words) - (setf end start)))))) - -(defun* split-name-type (filename) - (let ((unspecific - ;; 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 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 ".") - (if (equal name "") - (values filename unspecific) - (values name type))))) - -(defun* component-name-to-pathname-components (s &key force-directory force-relative) - "Splits the path string S, returning three values: -A flag that is either :absolute or :relative, indicating - how the rest of the values are to be interpreted. -A directory path --- a list of strings, suitable for - use with MAKE-PATHNAME when prepended with the flag - value. -A filename with type extension, possibly NIL in the - case of a directory pathname. -FORCE-DIRECTORY forces S to be interpreted as a directory -pathname \(third return value will be NIL, final component -of S will be treated as part of the directory path. - -The intention of this function is to support structured component names, -e.g., \(:file \"foo/bar\"\), which will be unpacked to relative -pathnames." - (check-type s string) - (when (find #\: s) - (error (compatfmt "~@") s)) - (let* ((components (split-string s :separator "/")) - (last-comp (car (last components)))) - (multiple-value-bind (relative components) - (if (equal (first components) "") - (if (equal (first-char s) #\/) - (progn - (when force-relative - (error (compatfmt "~@") s)) - (values :absolute (cdr components))) - (values :relative nil)) - (values :relative components)) - (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 - (force-directory - (values relative components nil)) - (t - (values relative (butlast components) last-comp)))))) - -(defun* remove-keys (key-names args) - (loop :for (name val) :on args :by #'cddr - :unless (member (symbol-name name) key-names - :key #'symbol-name :test 'equal) - :append (list name val))) - -(defun* remove-keyword (key args) - (loop :for (k v) :on args :by #'cddr - :unless (eq k key) - :append (list k v))) - -(defun* getenv (x) - (declare (ignorable x)) - #+(or abcl clisp ecl xcl) (ext:getenv x) - #+allegro (sys:getenv x) - #+clozure (ccl:getenv x) - #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=)) - #+cormanlisp - (let* ((buffer (ct:malloc 1)) - (cname (ct:lisp-string-to-c-string x)) - (needed-size (win:getenvironmentvariable cname buffer 0)) - (buffer1 (ct:malloc (1+ needed-size)))) - (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size)) - nil - (ct:c-string-to-lisp-string buffer1)) - (ct:free buffer) - (ct:free buffer1))) - #+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)))) - #+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 mkcl sbcl scl xcl) - (error "~S is not supported on your implementation" 'getenv)) - -(defun* directory-pathname-p (pathname) - "Does PATHNAME represent a directory? - -A directory-pathname is a pathname _without_ a filename. The three -ways that the filename components can be missing are for it to be NIL, -:UNSPECIFIC or the empty string. - -Note that this does _not_ check to see that PATHNAME points to an -actually-existing directory." +Returns the (parsed) PATHNAME when true" (when pathname - (let ((pathname (pathname pathname))) - (flet ((check-one (x) - (member x '(nil :unspecific "") :test 'equal))) - (and (not (wild-pathname-p pathname)) - (check-one (pathname-name pathname)) - (check-one (pathname-type pathname)) - t))))) + (let* ((pathname (pathname pathname)) + (name (pathname-name pathname))) + (when (not (member name '(nil :unspecific "") :test 'equal)) + pathname)))) (defun* ensure-directory-pathname (pathspec) "Converts the non-wild pathname designator PATHSPEC to directory form." @@ -789,194 +1602,393 @@ ((directory-pathname-p pathspec) pathspec) (t - (make-pathname :directory (append (or (pathname-directory pathspec) - (list :relative)) - (list (file-namestring pathspec))) - :name nil :type nil :version nil - :defaults pathspec)))) + (make-pathname* :directory (append (or (normalize-pathname-directory-component + (pathname-directory pathspec)) + (list :relative)) + (list (file-namestring pathspec))) + :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)))))) +;;; Wildcard pathnames +(defparameter *wild* (or #+cormanlisp "*" :wild)) +(defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild)) +(defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors)) +(defparameter *wild-file* + (make-pathname :directory nil :name *wild* :type *wild* + :version (or #-(or allegro abcl xcl) *wild*))) +(defparameter *wild-directory* + (make-pathname* :directory `(:relative ,*wild-directory-component*) + :name nil :type nil :version nil)) +(defparameter *wild-inferiors* + (make-pathname* :directory `(:relative ,*wild-inferiors-component*) + :name nil :type nil :version nil)) +(defparameter *wild-path* + (merge-pathnames* *wild-file* *wild-inferiors*)) -(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. - ;; NOTE that the host and device slots will be taken from the defaults, - ;; 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) - (symbol - (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) - :force-relative t) - (multiple-value-bind (name type) - (cond - ((or (eq type :directory) (null filename)) - (values nil nil)) - (type - (values filename type)) - (t - (split-name-type filename))) - (apply 'make-pathname :directory (cons relative path) :name name :type type - (when defaults `(:defaults ,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.016. - (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.") - (coerce-pathname name :type type :defaults defaults)) +(defun* wilden (path) + (merge-pathnames* *wild-path* path)) -(defun* subpathname (pathname subpath &key type) - (and pathname (merge-pathnames* (coerce-pathname subpath :type type) - (pathname-directory-pathname pathname)))) -(defun subpathname* (pathname subpath &key type) - (and pathname - (subpathname (ensure-directory-pathname pathname) subpath :type type))) +;;; Probing the filesystem +(defun* nil-pathname (&optional (defaults *default-pathname-defaults*)) + ;; 19.2.2.2.1 says a NIL host can mean a default host; + ;; see also "valid physical pathname host" in the CLHS glossary, that suggests + ;; strings and lists of strings or :unspecific + ;; But CMUCL decides to die on NIL. + (make-pathname* :directory nil :name nil :type nil :version nil :device nil + :host (or #+cmu lisp::*unix-host*) + ;; the default shouldn't matter, but we really want something physical + :defaults defaults)) + +(defmacro with-pathname-defaults ((&optional defaults) &body body) + `(let ((*default-pathname-defaults* ,(or defaults '(nil-pathname)))) , at body)) + +(defun* truename* (p) + ;; avoids both logical-pathname merging and physical resolution issues + (and p (ignore-errors (with-pathname-defaults () (truename p))))) + +(defun* probe-file* (p &key truename) + "when given a pathname P (designated by a string as per PARSE-NAMESTRING), +probes the filesystem for a file or directory with given pathname. +If it exists, return its truename is ENSURE-PATHNAME is true, +or the original (parsed) pathname if it is false (the default)." + (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations + (etypecase p + (null nil) + (string (probe-file* (parse-namestring p) :truename truename)) + (pathname (unless (wild-pathname-p p) + (let ((foundtrue + #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl) + '(probe-file p) + #+clisp (if-let (it (find-symbol* '#:probe-pathname :ext nil)) + `(ignore-errors (,it p))) + #+gcl2.6 + '(or (probe-file p) + (and (directory-pathname-p p) + (ignore-errors + (ensure-directory-pathname + (truename* (subpathname + (ensure-directory-pathname p) ".")))))) + '(truename* p)))) + (cond + (truename foundtrue) + (foundtrue p) + (t nil)))))))) -(defun* length=n-p (x n) ;is it that (= (length x) n) ? - (check-type n (integer 0 *)) - (loop - :for l = x :then (cdr l) - :for i :downfrom n :do - (cond - ((zerop i) (return (null l))) - ((not (consp l)) (return nil))))) +(defun* safe-file-write-date (pathname) + ;; If FILE-WRITE-DATE returns NIL, it's possible that + ;; the user or some other agent has deleted an input file. + ;; Also, generated files will not exist at the time planning is done + ;; and calls compute-action-stamp which calls safe-file-write-date. + ;; So it is very possible that we can't get a valid file-write-date, + ;; 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?) + (and (probe-file* pathname) (ignore-errors (file-write-date pathname)))) -(defun* string-suffix-p (s suffix) - (check-type s string) - (check-type suffix string) - (let ((start (- (length s) (length suffix)))) - (and (<= 0 start) - (string-equal s suffix :start1 start)))) - -(defun* read-file-forms (file) - (with-open-file (in file) - (loop :with eof = (list nil) - :for form = (read in nil eof) - :until (eq form eof) - :collect form))) +(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) + #+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 nil) + '(:resolve-symlinks nil)))))) -(defun* pathname-root (pathname) - (make-pathname :directory '(:absolute) - :name nil :type nil :version nil - :defaults pathname ;; host device, and on scl, *some* - ;; scheme-specific parts: port username password, not others: - . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) - -(defun* probe-file* (p) - "when given a pathname P, probes the filesystem for a file or directory -with given pathname and if it exists return its truename." - (etypecase p - (null nil) - (string (probe-file* (parse-namestring p))) - (pathname (unless (wild-pathname-p p) - #.(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))) - '(ignore-errors (truename p))))))) +(defun* filter-logical-directory-results (directory entries merger) + (if (logical-pathname-p directory) + ;; Try hard to not resolve logical-pathname into physical pathnames; + ;; otherwise logical-pathname users/lovers will be disappointed. + ;; If directory* could use some implementation-dependent magic, + ;; we will have logical pathnames already; otherwise, + ;; we only keep pathnames for which specifying the name and + ;; translating the LPN commute. + (loop :for f :in entries + :for p = (or (and (logical-pathname-p f) f) + (let* ((u (ignore-errors (funcall merger f)))) + ;; The first u avoids a cumbersome (truename u) error. + ;; At this point f should already be a truename, + ;; but isn't quite in CLISP, for it doesn't have :version :newest + (and u (equal (truename* u) (truename* f)) u))) + :when p :collect p) + entries)) -(defun* truenamize (pathname &optional (defaults *default-pathname-defaults*)) - "Resolve as much of a pathname as possible" - (block nil - (when (typep pathname '(or null logical-pathname)) (return pathname)) - (let ((p (merge-pathnames* pathname defaults))) - (when (typep p 'logical-pathname) (return p)) - (let ((found (probe-file* p))) - (when found (return found))) - (unless (absolute-pathname-p p) - (let ((true-defaults (ignore-errors (truename defaults)))) - (when true-defaults - (setf p (merge-pathnames pathname true-defaults))))) - (unless (absolute-pathname-p p) (return p)) - (let ((sofar (probe-file* (pathname-root p)))) - (unless sofar (return p)) - (flet ((solution (directories) - (merge-pathnames* - (make-pathname :host nil :device nil - :directory `(:relative , at directories) - :name (pathname-name p) - :type (pathname-type p) - :version (pathname-version p)) - sofar))) - (loop :with directory = (normalize-pathname-directory-component - (pathname-directory p)) - :for component :in (cdr directory) - :for rest :on (cdr directory) - :for more = (probe-file* - (merge-pathnames* - (make-pathname :directory `(:relative ,component)) - sofar)) :do - (if more - (setf sofar more) - (return (solution rest))) - :finally - (return (solution nil)))))))) +(defun* directory-files (directory &optional (pattern *wild-file*)) + (let ((dir (pathname directory))) + (when (logical-pathname-p dir) + ;; Because of the filtering we do below, + ;; logical pathnames have restrictions on wild patterns. + ;; Not that the results are very portable when you use these patterns on physical pathnames. + (when (wild-pathname-p dir) + (error "Invalid wild pattern in logical directory ~S" directory)) + (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) + (error "Invalid file pattern ~S for logical directory ~S" pattern directory)) + (setf pattern (make-pathname-logical pattern (pathname-host dir)))) + (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir))))) + (filter-logical-directory-results + directory entries + #'(lambda (f) + (make-pathname :defaults dir + :name (make-pathname-component-logical (pathname-name f)) + :type (make-pathname-component-logical (pathname-type f)) + :version (make-pathname-component-logical (pathname-version f)))))))) -(defun* resolve-symlinks (path) - #-allegro (truenamize path) - #+allegro (if (typep path 'logical-pathname) - path - (excl:pathname-resolve-symbolic-links path))) +(defun* subdirectories (directory) + (let* ((directory (ensure-directory-pathname directory)) + #-(or abcl cormanlisp genera xcl) + (wild (merge-pathnames* + #-(or abcl allegro cmu lispworks sbcl scl xcl) + *wild-directory* + #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" + directory)) + (dirs + #-(or abcl cormanlisp genera xcl) + (ignore-errors + (directory* wild . #.(or #+clozure '(:directories t :files nil) + #+mcl '(:directories t)))) + #+(or abcl xcl) (system:list-directory directory) + #+cormanlisp (cl::directory-subdirs directory) + #+genera (fs:directory-list directory)) + #+(or abcl allegro cmu genera lispworks sbcl scl xcl) + (dirs (loop :for x :in dirs + :for d = #+(or abcl xcl) (extensions:probe-directory x) + #+allegro (excl:probe-directory x) + #+(or cmu sbcl scl) (directory-pathname-p x) + #+genera (getf (cdr x) :directory) + #+lispworks (lw:file-directory-p x) + :when d :collect #+(or abcl allegro xcl) d + #+genera (ensure-directory-pathname (first x)) + #+(or cmu lispworks sbcl scl) x))) + (filter-logical-directory-results + directory dirs + (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory)) + '(:absolute)))) ; because allegro returns NIL for #p"FOO:" + #'(lambda (d) + (let ((dir (normalize-pathname-directory-component (pathname-directory d)))) + (and (consp dir) (consp (cdr dir)) + (make-pathname + :defaults directory :name nil :type nil :version nil + :directory (append prefix (make-pathname-component-logical (last dir))))))))))) -(defun* resolve-symlinks* (path) - (if *resolve-symlinks* - (and path (resolve-symlinks path)) - path)) +(defun* collect-sub*directories (directory collectp recursep collector) + (when (funcall collectp directory) + (funcall collector directory)) + (dolist (subdir (subdirectories directory)) + (when (funcall recursep subdir) + (collect-sub*directories subdir collectp recursep collector)))) -(defun* ensure-pathname-absolute (path) - (cond - ((absolute-pathname-p path) path) - ((stringp path) (ensure-pathname-absolute (pathname path))) - ((not (pathnamep path)) (error "not a valid pathname designator ~S" path)) - (t (let ((resolved (resolve-symlinks path))) - (assert (absolute-pathname-p resolved)) - resolved)))) -(defun* default-directory () - (truenamize (pathname-directory-pathname *default-pathname-defaults*))) +;;; Parsing filenames and lists thereof +(defun* split-unix-namestring-directory-components + (unix-namestring &key ensure-directory dot-dot) + "Splits the path string UNIX-NAMESTRING, returning four values: +A flag that is either :absolute or :relative, indicating + how the rest of the values are to be interpreted. +A directory path --- a list of strings and keywords, suitable for + use with MAKE-PATHNAME when prepended with the flag value. + Directory components with an empty name or the name . are removed. + Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP). +A last-component, either a file-namestring including type extension, + or NIL in the case of a directory pathname. +A flag that is true iff the unix-style-pathname was just + a file-namestring without / path specification. +ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname: +the third return value will be NIL, and final component of the namestring +will be treated as part of the directory path. -(defun* lispize-pathname (input-file) - (make-pathname :type "lisp" :defaults input-file)) +An empty string is thus read as meaning a pathname object with all fields nil. -(defparameter *wild* #-cormanlisp :wild #+cormanlisp "*") -(defparameter *wild-file* - (make-pathname :name *wild* :type *wild* - :version (or #-(or abcl xcl) *wild*) :directory nil)) -(defparameter *wild-directory* - (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil)) -(defparameter *wild-inferiors* - (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil)) -(defparameter *wild-path* - (merge-pathnames *wild-file* *wild-inferiors*)) +Note that : characters will NOT be interpreted as host specification. +Absolute pathnames are only appropriate on Unix-style systems. -(defun* wilden (path) - (merge-pathnames* *wild-path* path)) +The intention of this function is to support structured component names, +e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames." + (check-type unix-namestring string) + (check-type dot-dot (member nil :back :up)) + (if (and (not (find #\/ unix-namestring)) (not ensure-directory) + (plusp (length unix-namestring))) + (values :relative () unix-namestring t) + (let* ((components (split-string unix-namestring :separator "/")) + (last-comp (car (last components)))) + (multiple-value-bind (relative components) + (if (equal (first components) "") + (if (equal (first-char unix-namestring) #\/) + (values :absolute (cdr components)) + (values :relative nil)) + (values :relative components)) + (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) + components)) + (setf components (substitute (or dot-dot :back) ".." components :test #'equal)) + (cond + ((equal last-comp "") + (values relative components nil nil)) ; "" already removed from components + (ensure-directory + (values relative components nil nil)) + (t + (values relative (butlast components) last-comp nil))))))) + +(defun* split-name-type (filename) + "Split a filename into two values NAME and TYPE that are returned. +We assume filename has no directory component. +The last . if any separates name and type from from type, +except that if there is only one . and it is in first position, +the whole filename is the NAME with an empty type. +NAME is always a string. +For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned." + (check-type filename string) + (assert (plusp (length filename))) + (destructuring-bind (name &optional (type *unspecific-pathname-type*)) + (split-string filename :max 2 :separator ".") + (if (equal name "") + (values filename *unspecific-pathname-type*) + (values name type)))) + +(defun* parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory + &allow-other-keys) + "Coerce NAME into a PATHNAME using standard Unix syntax. + +Unix syntax is used whether or not the underlying system is Unix; +on such non-Unix systems it is only usable but for relative pathnames; +but especially to manipulate relative pathnames portably, it is of crucial +to possess a portable pathname syntax independent of the underlying OS. +This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF. + +When given a PATHNAME object, just return it untouched. +When given NIL, just return NIL. +When given a non-null SYMBOL, first downcase its name and treat it as a string. +When given a STRING, portably decompose it into a pathname as below. + +#\\/ separates directory components. + +The last #\\/-separated substring is interpreted as follows: +1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true, + the string is made the last directory component, and NAME and TYPE are NIL. + if the string is empty, it's the empty pathname with all slots NIL. +2- If TYPE is NIL, the substring is file-namestring, and its NAME and TYPE + are separated by SPLIT-NAME-TYPE. +3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME. + +Directory components with an empty name the name . are removed. +Any directory named .. is read as DOT-DOT, +which must be one of :BACK or :UP and defaults to :BACK. + +HOST, DEVICE and VERSION components are taken from DEFAULTS, +which itself defaults to (ROOT-PATHNAME), also used if DEFAULTS in NIL. +No host or device can be specified in the string itself, +which makes it unsuitable for absolute pathnames outside Unix. + +For relative pathnames, these components (and hence the defaults) won't matter +if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES, +which is an important reason to always use MERGE-PATHNAMES*. + +Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME +with those keys, removing TYPE DEFAULTS and DOT-DOT. +When you're manipulating pathnames that are supposed to make sense portably +even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T +to throw an error if the pathname is absolute" + (block nil + (check-type type (or null string (eql :directory))) + (when ensure-directory + (setf type :directory)) + (etypecase name + ((or null pathname) (return name)) + (symbol + (setf name (string-downcase name))) + (string)) + (multiple-value-bind (relative path filename file-only) + (split-unix-namestring-directory-components + name :dot-dot dot-dot :ensure-directory (eq type :directory)) + (multiple-value-bind (name type) + (cond + ((or (eq type :directory) (null filename)) + (values nil nil)) + (type + (values filename type)) + (t + (split-name-type filename))) + (apply 'ensure-pathname + (make-pathname* + :directory (unless file-only (cons relative path)) + :name name :type type + :defaults (or defaults (nil-pathname))) + (remove-plist-keys '(:type :dot-dot :defaults) keys)))))) + +(defun* unix-namestring (pathname) + "Given a non-wild PATHNAME, return a Unix-style namestring for it. +If the PATHNAME is NIL or a STRING, return it unchanged. + +This only considers the DIRECTORY, NAME and TYPE components of the pathname. +This is a portable solution for representing relative pathnames, +But unless you are running on a Unix system, it is not a general solution +to representing native pathnames. + +An error is signaled if the argument is not NULL, a STRING or a PATHNAME, +or if it is a PATHNAME but some of its components are not recognized." + (etypecase pathname + ((or null string) pathname) + (pathname + (with-output-to-string (s) + (flet ((err () (error "Not a valid unix-namestring ~S" pathname))) + (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname))) + (name (pathname-name pathname)) + (type (pathname-type pathname)) + (type (and (not (eq type :unspecific)) type))) + (cond + ((eq dir ())) + ((eq dir '(:relative)) (princ "./" s)) + ((consp dir) + (destructuring-bind (relabs &rest dirs) dir + (or (member relabs '(:relative :absolute)) (err)) + (when (eq relabs :absolute) (princ #\/ s)) + (loop :for x :in dirs :do + (cond + ((member x '(:back :up)) (princ "../" s)) + ((equal x "") (err)) + ;;((member x '("." "..") :test 'equal) (err)) + ((stringp x) (format s "~A/" x)) + (t (err)))))) + (t (err))) + (cond + (name + (or (and (stringp name) (or (null type) (stringp type))) (err)) + (format s "~A~@[.~A~]" name type)) + (t + (or (null type) (err)))))))))) + +(defun* subpathname (pathname subpath &key type) + "This function takes a PATHNAME and a SUBPATH and a TYPE. +If SUBPATH is already a PATHNAME object (not namestring), +and is an absolute pathname at that, it is returned unchanged; +otherwise, SUBPATH is turned into a relative pathname with given TYPE +as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE, +then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." + (or (and (pathnamep subpath) (absolute-pathname-p subpath)) + (merge-pathnames* (parse-unix-namestring subpath :type type :want-relative t) + (pathname-directory-pathname pathname)))) + +(defun* subpathname* (pathname subpath &key type) + "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME." + (and pathname + (subpathname (ensure-directory-pathname pathname) subpath :type type))) + +;;; Pathname host and its root +(defun* pathname-root (pathname) + (make-pathname* :directory '(:absolute) + :name nil :type nil :version nil + :defaults pathname ;; host device, and on scl, *some* + ;; scheme-specific parts: port username password, not others: + . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) + +(defun* pathname-host-pathname (pathname) + (make-pathname* :directory nil + :name nil :type nil :version nil :device nil + :defaults pathname ;; host device, and on scl, *some* + ;; scheme-specific parts: port username password, not others: + . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) #-scl (defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) - (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname))) + (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname))) (last-char (namestring foo)))) #-scl @@ -992,11 +2004,10 @@ (eql x separator))) root-namestring))) (multiple-value-bind (relative path filename) - (component-name-to-pathname-components root-string :force-directory t) + (split-unix-namestring-directory-components root-string :ensure-directory t) (declare (ignore relative filename)) (let ((new-base - (make-pathname :defaults root - :directory `(:absolute , at path)))) + (make-pathname* :defaults root :directory `(:absolute , at path)))) (translate-pathname absolute-pathname wild-root (wilden new-base)))))) #+scl @@ -1018,389 +2029,727 @@ (when (specificp scheme) (setf prefix (strcat scheme prefix))) (assert (and directory (eq (first directory) :absolute))) - (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) - :defaults pathname))) + (make-pathname* :directory `(:absolute ,prefix ,@(rest directory)) + :defaults pathname))) pathname))) -;;;; ------------------------------------------------------------------------- -;;;; ASDF Interface, in terms of generic functions. -(defgeneric* find-system (system &optional error-p)) -(defgeneric* perform-with-restarts (operation component)) -(defgeneric* perform (operation component)) -(defgeneric* operation-done-p (operation component)) -(defgeneric* mark-operation-done (operation component)) -(defgeneric* explain (operation component)) -(defgeneric* output-files (operation component)) -(defgeneric* input-files (operation component)) -(defgeneric* component-operation-time (operation component)) -(defgeneric* operation-description (operation component) - (:documentation "returns a phrase that describes performing this operation -on this component, e.g. \"loading /a/b/c\". -You can put together sentences using this phrase.")) - -(defgeneric* system-source-file (system) - (:documentation "Return the source file in which system is defined.")) - -(defgeneric* component-system (component) - (:documentation "Find the top-level system containing COMPONENT")) - -(defgeneric* component-pathname (component) - (:documentation "Extracts the pathname applicable for a particular component.")) +(defun* subpathp (maybe-subpath base-pathname) + (and (pathnamep maybe-subpath) (pathnamep base-pathname) + (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname) + (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname)) + (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname)) + (with-pathname-defaults () + (let ((enough (enough-namestring maybe-subpath base-pathname))) + (and (relative-pathname-p enough) (pathname enough)))))) -(defgeneric* component-relative-pathname (component) - (:documentation "Returns a pathname for the component argument intended to be -interpreted relative to the pathname of that component's parent. -Despite the function's name, the return value may be an absolute -pathname, because an absolute pathname may be interpreted relative to -another pathname in a degenerate way.")) -(defgeneric* component-property (component property)) - -(defgeneric* (setf component-property) (new-value component property)) - -(defgeneric* component-external-format (component)) +;;; Resolving symlinks somewhat +(defun* truenamize (pathname &optional (defaults *default-pathname-defaults*)) + "Resolve as much of a pathname as possible" + (block nil + (when (typep pathname '(or null logical-pathname)) (return pathname)) + (let ((p (merge-pathnames* pathname defaults))) + (when (logical-pathname-p p) (return p)) + (let ((found (probe-file* p :truename t))) + (when found (return found))) + (unless (absolute-pathname-p p) + (let ((true-defaults (truename* defaults))) + (when true-defaults + (setf p (merge-pathnames pathname true-defaults))))) + (unless (absolute-pathname-p p) (return p)) + (let ((sofar (probe-file* (pathname-root p) :truename t))) + (unless sofar (return p)) + (flet ((solution (directories) + (merge-pathnames* + (make-pathname* :host nil :device nil + :directory `(:relative , at directories) + :name (pathname-name p) + :type (pathname-type p) + :version (pathname-version p)) + sofar))) + (loop :with directory = (normalize-pathname-directory-component + (pathname-directory p)) + :for dir :in (cdr directory) + :for rest :on (cdr directory) + :for more = (probe-file* + (merge-pathnames* + (make-pathname* :directory `(:relative ,dir)) + sofar) :truename t) :do + (if more + (setf sofar more) + (return (solution rest))) + :finally + (return (solution nil)))))))) -(defgeneric* component-encoding (component)) +(defun* resolve-symlinks (path) + #-allegro (truenamize path) + #+allegro + (if (physical-pathname-p path) + (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path) + path)) -(eval-when (#-gcl :compile-toplevel :load-toplevel :execute) - (defgeneric* (setf module-components-by-name) (new-value module))) +(defun* resolve-symlinks* (path) + (if *resolve-symlinks* + (and path (resolve-symlinks path)) + path)) -(defgeneric* version-satisfies (component version)) -(defgeneric* find-component (base path) - (:documentation "Finds the component with PATH starting from BASE module; -if BASE is nil, then the component is assumed to be a system.")) +;;; absolute vs relative +(defun* ensure-pathname-absolute (path &optional defaults (on-error 'error)) + (cond + ((absolute-pathname-p path)) + ((stringp path) (ensure-pathname-absolute (pathname path) defaults)) + ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path)) + ((absolute-pathname-p defaults) + (or (absolute-pathname-p (merge-pathnames* path defaults)) + (call-function on-error "Failed to merge ~S with ~S into an absolute pathname" + path defaults))) + (t (call-function on-error + "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S" + path defaults)))) -(defgeneric* source-file-type (component system)) +(defun relativize-directory-component (directory-component) + (let ((directory (normalize-pathname-directory-component directory-component))) + (cond + ((stringp directory) + (list :relative directory)) + ((eq (car directory) :absolute) + (cons :relative (cdr directory))) + (t + directory)))) -(defgeneric* operation-ancestor (operation) - (:documentation - "Recursively chase the operation's parent pointer until we get to -the head of the tree")) +(defun* relativize-pathname-directory (pathspec) + (let ((p (pathname pathspec))) + (make-pathname* + :directory (relativize-directory-component (pathname-directory p)) + :defaults p))) -(defgeneric* component-visited-p (operation component) - (:documentation "Returns the value stored by a call to -VISIT-COMPONENT, if that has been called, otherwise NIL. -This value stored will be a cons cell, the first element -of which is a computed key, so not interesting. The -CDR wil be the DATA value stored by VISIT-COMPONENT; recover -it as (cdr (component-visited-p op c)). - In the current form of ASDF, the DATA value retrieved is -effectively a boolean, indicating whether some operations are -to be performed in order to do OPERATION X COMPONENT. If the -data value is NIL, the combination had been explored, but no -operations needed to be performed.")) - -(defgeneric* visit-component (operation component data) - (:documentation "Record DATA as being associated with OPERATION -and COMPONENT. This is a side-effecting function: the association -will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the -OPERATION\). - No evidence that DATA is ever interesting, beyond just being -non-NIL. Using the data field is probably very risky; if there is -already a record for OPERATION X COMPONENT, DATA will be quietly -discarded instead of recorded. - Starting with 2.006, TRAVERSE will store an integer in data, -so that nodes can be sorted in decreasing order of traversal.")) +;;; Simple filesystem operations +(defun* ensure-all-directories-exist (pathnames) + (dolist (pathname pathnames) + (ensure-directories-exist (translate-logical-pathname pathname)))) -(defgeneric* (setf visiting-component) (new-value operation component)) +(defun* rename-file-overwriting-target (source target) + #+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic + (posix:copy-file source target :method :rename) + #-clisp + (rename-file source target + #+clozure :if-exists #+clozure :rename-and-delete)) -(defgeneric* component-visiting-p (operation component)) +(defun* delete-file-if-exists (x) + (when (probe-file* x) + (delete-file x))) -(defgeneric* component-depends-on (operation component) - (:documentation - "Returns a list of dependencies needed by the component to perform - the operation. A dependency has one of the following forms: +;;; Translate a pathname +(defun* (translate-pathname*) (path absolute-source destination &optional root source) + (declare (ignore source)) + (cond + ((functionp destination) + (funcall destination path absolute-source)) + ((eq destination t) + path) + ((not (pathnamep destination)) + (error "Invalid destination")) + ((not (absolute-pathname-p destination)) + (translate-pathname path absolute-source (merge-pathnames* destination root))) + (root + (translate-pathname (directorize-pathname-host-device path) absolute-source destination)) + (t + (translate-pathname path absolute-source destination)))) - ( *), where is a class - designator and each is a component - designator, which means that the component depends on - having been performed on each ; or - (FEATURE ), which means that the component depends - on 's presence in *FEATURES*. +;;; Temporary pathnames +(defun* add-pathname-suffix (pathname suffix) + (make-pathname :name (strcat (pathname-name pathname) suffix) + :defaults pathname)) - Methods specialized on subclasses of existing component types - should usually append the results of CALL-NEXT-METHOD to the - list.")) +(defun* tmpize-pathname (x) + (add-pathname-suffix x "-ASDF-TMP")) -(defgeneric* component-self-dependencies (operation component)) +(defun* call-with-staging-pathname (pathname fun) + "Calls fun with a staging pathname, and atomically +renames the staging pathname to the pathname in the end. +Note: this protects only against failure of the program, +not against concurrent attempts. +For the latter case, we ought pick random suffix and atomically open it." + (let* ((pathname (pathname pathname)) + (staging (tmpize-pathname pathname))) + (unwind-protect + (multiple-value-prog1 + (funcall fun staging) + (rename-file-overwriting-target staging pathname)) + (delete-file-if-exists staging)))) + +(defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body) + `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) , at body))) + +;;; Basic pathnames +(defun* sane-physical-pathname (&key defaults (keep t) fallback want-existing) + (flet ((sanitize (x) + (setf x (and x (ignore-errors (translate-logical-pathname x)))) + (when (pathnamep x) + (setf x + (ecase keep + ((t) x) + ((:directory) (pathname-directory-pathname x)) + ((:root) (pathname-root x)) + ((:host) (pathname-host-pathname x)) + ((nil) (nil-pathname x)))) + (when want-existing ;; CCL's probe-file will choke if d-p-d is logical + (setf x (probe-file* x))) + (and (physical-pathname-p x) x)))) + (or (sanitize defaults) + (when fallback + (or (sanitize (nil-pathname)) + (sanitize (ignore-errors (user-homedir-pathname))))) + (error "Could not find a sane a physical pathname~ + ~@[ from ~S~]~@[~:*~@[ or~*~] fallbacks~]" + defaults fallback)))) + +(defun* root-pathname () + "On a Unix system, this will presumably be the root pathname /. +Otherwise, this will be the root of some implementation-dependent filesystem host." + (sane-physical-pathname :keep :root :fallback t)) -(defgeneric* traverse (operation component) - (:documentation -"Generate and return a plan for performing OPERATION on COMPONENT. -The plan returned is a list of dotted-pairs. Each pair is the CONS -of ASDF operation object and a COMPONENT object. The pairs will be -processed in order by OPERATE.")) +;;;; ----------------------------------------------------------------- +;;;; Windows shortcut support. Based on: +;;;; +;;;; Jesse Hager: The Windows Shortcut File Format. +;;;; http://www.wotsit.org/list.asp?fc=13 +#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera. +(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)) -;;;; ------------------------------------------------------------------------- -;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687 -(when *upgraded-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 *asdf-verbose* - (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) - (when (member 'source-file added) - (%set-system-source-file - (probe-asd (component-name m) (component-pathname m)) m) - (when (equal (component-name m) "asdf") - (setf (component-version m) *asdf-version*)))))))) +(defun* read-null-terminated-string (s) + (with-output-to-string (out) + (loop :for code = (read-byte s) + :until (zerop code) + :do (write-char (code-char code) out)))) -;;;; ------------------------------------------------------------------------- -;;;; Classes, Conditions +(defun* read-little-endian (s &optional (bytes 4)) + (loop :for i :from 0 :below bytes + :sum (ash (read-byte s) (* 8 i)))) -(define-condition system-definition-error (error) () - ;; [this use of :report should be redundant, but unfortunately it's not. - ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function - ;; over print-object; this is always conditions::%print-condition for - ;; condition objects, which in turn does inheritance of :report options at - ;; run-time. fortunately, inheritance means we only need this kludge here in - ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] - #+cmu (:report print-object)) +(defun* parse-file-location-info (s) + (let ((start (file-position s)) + (total-length (read-little-endian s)) + (end-of-header (read-little-endian s)) + (fli-flags (read-little-endian s)) + (local-volume-offset (read-little-endian s)) + (local-offset (read-little-endian s)) + (network-volume-offset (read-little-endian s)) + (remaining-offset (read-little-endian s))) + (declare (ignore total-length end-of-header local-volume-offset)) + (unless (zerop fli-flags) + (cond + ((logbitp 0 fli-flags) + (file-position s (+ start local-offset))) + ((logbitp 1 fli-flags) + (file-position s (+ start + network-volume-offset + #x14)))) + (strcat (read-null-terminated-string s) + (progn + (file-position s (+ start remaining-offset)) + (read-null-terminated-string s)))))) -(define-condition formatted-system-definition-error (system-definition-error) - ((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))))) +(defun* parse-windows-shortcut (pathname) + (with-open-file (s pathname :element-type '(unsigned-byte 8)) + (handler-case + (when (and (= (read-little-endian s) *link-initial-dword*) + (let ((header (make-array (length *link-guid*)))) + (read-sequence header s) + (equalp header *link-guid*))) + (let ((flags (read-little-endian s))) + (file-position s 76) ;skip rest of header + (when (logbitp 0 flags) + ;; skip shell item id list + (let ((length (read-little-endian s 2))) + (file-position s (+ length (file-position s))))) + (cond + ((logbitp 1 flags) + (parse-file-location-info s)) + (t + (when (logbitp 2 flags) + ;; skip description string + (let ((length (read-little-endian s 2))) + (file-position s (+ length (file-position s))))) + (when (logbitp 3 flags) + ;; finally, our pathname + (let* ((length (read-little-endian s 2)) + (buffer (make-array length))) + (read-sequence buffer s) + (map 'string #'code-char buffer))))))) + (end-of-file (c) + (declare (ignore c)) + nil))))) -(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 (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) - (format s (compatfmt "~@") - (circular-dependency-components c))))) +;;; Check pathname constraints -(define-condition duplicate-names (system-definition-error) - ((name :initarg :name :reader duplicate-names-name)) - (:report (lambda (c s) - (format s (compatfmt "~@") - (duplicate-names-name c))))) +(defun* ensure-pathname + (pathname &key + on-error + defaults type dot-dot + want-pathname + want-logical want-physical ensure-physical + want-relative want-absolute ensure-absolute ensure-subpath + want-non-wild want-wild wilden + want-file want-directory ensure-directory + want-existing ensure-directories-exist + truename resolve-symlinks truenamize + &aux (p pathname)) ;; mutable working copy, preserve original + "Coerces its argument into a PATHNAME, +optionally doing some transformations and checking specified constraints. + +If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified. + +If the argument is a STRING, it is first converted to a pathname via PARSE-UNIX-NAMESTRING +reusing the keywords DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE; +then the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true, +and the all the checks and transformations are run. + +Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE. +The boolean T is an alias for ERROR. +ERROR means that an error will be raised if the constraint is not satisfied. +CERROR means that an continuable error will be raised if the constraint is not satisfied. +IGNORE means just return NIL instead of the pathname. + +The ON-ERROR argument, if not NIL, is a function designator (as per CALL-FUNCTION) +that will be called with the the following arguments: +a generic format string for ensure pathname, the pathname, +the keyword argument corresponding to the failed check or transformation, +a format string for the reason ENSURE-PATHNAME failed, +and a list with arguments to that format string. +If ON-ERROR is NIL, ERROR is used instead, which does the right thing. +You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\"). + +The transformations and constraint checks are done in this order, +which is also the order in the lambda-list: + +WANT-PATHNAME checks that pathname (after parsing if needed) is not null. +Otherwise, if the pathname is NIL, ensure-pathname returns NIL. +WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME +WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME +ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PATHNAME +WANT-RELATIVE checks that pathname has a relative directory component +WANT-ABSOLUTE checks that pathname does have an absolute directory component +ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again +that the result absolute is an absolute pathname indeed. +ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS. +WANT-FILE checks that pathname has a non-nil FILE component +WANT-DIRECTORY checks that pathname has nil FILE and TYPE components +ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret +any file and type components as being actually a last directory component. +WANT-NON-WILD checks that pathname is not a wild pathname +WANT-WILD checks that pathname is a wild pathname +WILDEN merges the pathname with **/*.*.* if it is not wild +WANT-EXISTING checks that a file (or directory) exists with that pathname. +ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST. +TRUENAME replaces the pathname by its truename, or errors if not possible. +RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS. +TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." + (block nil + (flet ((report-error (keyword description &rest arguments) + (call-function (or on-error 'error) + "Invalid pathname ~S: ~*~?" + pathname keyword description arguments))) + (macrolet ((err (constraint &rest arguments) + `(report-error ',(intern* constraint :keyword) , at arguments)) + (check (constraint condition &rest arguments) + `(when ,constraint + (unless ,condition (err ,constraint , at arguments)))) + (transform (transform condition expr) + `(when ,transform + (,@(if condition `(when ,condition) '(progn)) + (setf p ,expr))))) + (etypecase p + ((or null pathname)) + (string + (setf p (parse-unix-namestring + p :defaults defaults :type type :dot-dot dot-dot + :ensure-directory ensure-directory :want-relative want-relative)))) + (check want-pathname (pathnamep p) "Expected a pathname, not NIL") + (unless (pathnamep p) (return nil)) + (check want-logical (logical-pathname-p p) "Expected a logical pathname") + (check want-physical (physical-pathname-p p) "Expected a physical pathname") + (transform ensure-physical () (translate-logical-pathname p)) + (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname") + (check want-relative (relative-pathname-p p) "Expected a relative pathname") + (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname") + (transform ensure-absolute (not (absolute-pathname-p p)) (merge-pathnames* p defaults)) + (check ensure-absolute (absolute-pathname-p p) + "Could not make into an absolute pathname even after merging with ~S" defaults) + (check ensure-subpath (absolute-pathname-p defaults) + "cannot be checked to be a subpath of non-absolute pathname ~S" defaults) + (check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults) + (check want-file (file-pathname-p p) "Expected a file pathname") + (check want-directory (directory-pathname-p p) "Expected a directory pathname") + (transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p)) + (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wildcard pathname") + (check want-wild (wild-pathname-p p) "Expected a wildcard pathname") + (transform wilden (not (wild-pathname-p p)) (wilden p)) + (when want-existing + (let ((existing (probe-file* p :truename truename))) + (if existing + (when truename + (return existing)) + (err want-existing "Expected an existing pathname")))) + (when ensure-directories-exist (ensure-directories-exist p)) + (when truename + (let ((truename (truename* p))) + (if truename + (return truename) + (err truename "Can't get a truename for pathname")))) + (transform resolve-symlinks () (resolve-symlinks p)) + (transform truenamize () (truenamize p)) + p)))) + + +(defun absolutize-pathnames + (pathnames &key type (resolve-symlinks *resolve-symlinks*) truename) + "Given a list of PATHNAMES where each is in the context of the next ones, +try to resolve these pathnames into an absolute pathname; first gently, then harder." + (block nil + (labels ((resolve (x) + (or (when truename + (absolute-pathname-p (truename* x))) + (when resolve-symlinks + (absolute-pathname-p (resolve-symlinks x))) + (absolute-pathname-p x) + (unless resolve-symlinks + (absolute-pathname-p (resolve-symlinks x))) + (unless truename + (absolute-pathname-p (truename* x))) + (return nil))) + (tryone (x type rest) + (resolve (or (absolute-pathname-p x) + (subpathname (recurse rest :directory) x :type type)))) + (recurse (pathnames type) + (if (null pathnames) (return nil) + (tryone (first pathnames) type (rest pathnames))))) + (recurse pathnames type)))) -(define-condition missing-component (system-definition-error) - ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) - (parent :initform nil :reader missing-parent :initarg :parent))) -(define-condition missing-component-of-version (missing-component) - ((version :initform nil :reader missing-version :initarg :version))) +;;; Hook for output translations +(defvar *output-translation-function* 'identity) +;;;; --------------------------------------------------------------------------- +;;;; Utilities related to streams -(define-condition missing-dependency (missing-component) - ((required-by :initarg :required-by :reader missing-required-by))) +(asdf/package:define-package :asdf/stream + (:recycle :asdf/stream) + (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/pathname) + (:export + #:*default-stream-element-type* #:*stderr* #:setup-stderr + #:with-safe-io-syntax #:call-with-safe-io-syntax + #:with-output #:output-string #:with-input + #:with-input-file #:call-with-input-file + #:finish-outputs #:format! #:safe-format! + #:copy-stream-to-stream #:concatenate-files + #:copy-stream-to-stream-line-by-line + #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line + #:slurp-stream-forms #:slurp-stream-form + #:read-file-string #:read-file-lines #:read-file-forms #:read-file-form #:safe-read-file-form + #:eval-input #:eval-thunk #:standard-eval-thunk + #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding + #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format + #:*default-encoding* #:*utf-8-external-format*)) +(in-package :asdf/stream) + +(defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default) + "default element-type for open (depends on the current CL implementation)") + +(defvar *stderr* *error-output* + "the original error output stream at startup") + +(defun setup-stderr () + (setf *stderr* + #+allegro excl::*stderr* + #+clozure ccl::*stderr* + #-(or allegro clozure) *error-output*)) +(setup-stderr) + + +;;; Safe syntax + +(defvar *standard-readtable* (copy-readtable nil)) + +(defmacro with-safe-io-syntax ((&key (package :cl)) &body body) + "Establish safe CL reader options around the evaluation of BODY" + `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) , at body)))) + +(defun* call-with-safe-io-syntax (thunk &key (package :cl)) + (with-standard-io-syntax () + (let ((*package* (find-package package)) + (*readtable* *standard-readtable*) + (*read-default-float-format* 'double-float) + (*print-readably* nil) + (*read-eval* nil)) + (funcall thunk)))) + + +;;; Output to a stream or string, FORMAT-style + +(defun* call-with-output (output function) + "Calls FUNCTION with an actual stream argument, +behaving like FORMAT with respect to how stream designators are interpreted: +If OUTPUT is a stream, use it as the stream. +If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string. +If OUTPUT is T, use *STANDARD-OUTPUT* as the stream. +If OUTPUT is a string with a fill-pointer, use it as a string-output-stream. +Otherwise, signal an error." + (etypecase output + (null + (with-output-to-string (stream) (funcall function stream))) + ((eql t) + (funcall function *standard-output*)) + (stream + (funcall function output)) + (string + (assert (fill-pointer output)) + (with-output-to-string (stream output) (funcall function stream))))) -(define-condition missing-dependency-of-version (missing-dependency - missing-component-of-version) - ()) +(defmacro with-output ((output-var &optional (value output-var)) &body body) + "Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous binding of OUTPUT-VAR) +as per FORMAT, and evaluate BODY within the scope of this binding." + `(call-with-output ,value #'(lambda (,output-var) , at body))) + +(defun* output-string (string &optional output) + "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string" + (if output + (with-output (output) (princ string output)) + string)) + + +;;; Input helpers + +(defun* call-with-input (input function) + "Calls FUNCTION with an actual stream argument, interpreting +stream designators like READ, but also coercing strings to STRING-INPUT-STREAM. +If INPUT is a STREAM, use it as the stream. +If INPUT is NIL, use a *STANDARD-INPUT* as the stream. +If INPUT is T, use *TERMINAL-IO* as the stream. +As an extension, if INPUT is a string, use it as a string-input-stream. +Otherwise, signal an error." + (etypecase input + (null (funcall function *standard-input*)) + ((eql t) (funcall function *terminal-io*)) + (stream (funcall function input)) + (string (with-input-from-string (stream input) (funcall function stream))))) + +(defmacro with-input ((input-var &optional (value input-var)) &body body) + "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR) +as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding." + `(call-with-input ,value #'(lambda (,input-var) , at body))) + +(defun* call-with-input-file (pathname thunk + &key + (element-type *default-stream-element-type*) + (external-format :default) + (if-does-not-exist :error)) + "Open FILE for input with given recognizes options, call THUNK with the resulting stream. +Other keys are accepted but discarded." + #+gcl2.6 (declare (ignore external-format)) + (with-open-file (s pathname :direction :input + :element-type element-type + #-gcl2.6 :external-format #-gcl2.6 external-format + :if-does-not-exist if-does-not-exist) + (funcall thunk s))) + +(defmacro with-input-file ((var pathname &rest keys &key element-type external-format) &body body) + (declare (ignore element-type external-format)) + `(call-with-input-file ,pathname #'(lambda (,var) , at body) , at keys)) + + +;;; Ensure output buffers are flushed + +(defun* finish-outputs (&rest streams) + "Finish output on the main output streams as well as any specified one. +Useful for portably flushing I/O before user input or program exit." + ;; CCL notably buffers its stream output by default. + (dolist (s (append streams + (list *stderr* *error-output* *standard-output* *trace-output* + *debug-io* *terminal-io* *debug-io* *query-io*))) + (ignore-errors (finish-output s))) + (values)) -(define-condition operation-error (error) - ((component :reader error-component :initarg :component) - (operation :reader error-operation :initarg :operation)) - (:report (lambda (c s) - (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>") - (type-of c) (error-operation c) (error-component c))))) -(define-condition compile-error (operation-error) ()) -(define-condition compile-failed (compile-error) ()) -(define-condition compile-warned (compile-error) ()) +(defun* format! (stream format &rest args) + "Just like format, but call finish-outputs before and after the output." + (finish-outputs stream) + (apply 'format stream format args) + (finish-output stream)) + +(defun* safe-format! (stream format &rest args) + (with-safe-io-syntax () + (ignore-errors (apply 'format! stream format args)) + (finish-outputs stream))) ; just in case format failed + + +;;; Simple Whole-Stream processing + + +(defun* copy-stream-to-stream (input output &key element-type buffer-size linewise prefix) + "Copy the contents of the INPUT stream into the OUTPUT stream. +If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX. +Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE." + (with-open-stream (input input) + (if linewise + (loop* :for (line eof) = (multiple-value-list (read-line input nil nil)) + :while line :do + (when prefix (princ prefix output)) + (princ line output) + (unless eof (terpri output)) + (finish-output output) + (when eof (return))) + (loop + :with buffer-size = (or buffer-size 8192) + :for buffer = (make-array (list buffer-size) :element-type (or element-type 'character)) + :for end = (read-sequence buffer input) + :until (zerop end) + :do (write-sequence buffer output :end end) + (when (< end buffer-size) (return)))))) + +(defun* concatenate-files (inputs output) + (with-open-file (o output :element-type '(unsigned-byte 8) + :direction :output :if-exists :rename-and-delete) + (dolist (input inputs) + (with-open-file (i input :element-type '(unsigned-byte 8) + :direction :input :if-does-not-exist :error) + (copy-stream-to-stream i o :element-type '(unsigned-byte 8)))))) + +(defun* slurp-stream-string (input &key (element-type 'character)) + "Read the contents of the INPUT stream as a string" + (with-open-stream (input input) + (with-output-to-string (output) + (copy-stream-to-stream input output :element-type element-type)))) + +(defun* slurp-stream-lines (input &key count) + "Read the contents of the INPUT stream as a list of lines, return those lines. + +Read no more than COUNT lines." + (check-type count (or null integer)) + (with-open-stream (input input) + (loop :for n :from 0 + :for l = (and (or (not count) (< n count)) + (read-line input nil nil)) + :while l :collect l))) + +(defun* slurp-stream-line (input &key (at 0)) + "Read the contents of the INPUT stream as a list of lines, +then return the ACCESS-AT of that list of lines using the AT specifier. +PATH defaults to 0, i.e. return the first line. +PATH is typically an integer, or a list of an integer and a function. +If PATH is NIL, it will return all the lines in the file. + +The stream will not be read beyond the Nth lines, +where N is the index specified by path +if path is either an integer or a list that starts with an integer." + (access-at (slurp-stream-lines input :count (access-at-count at)) at)) + +(defun* slurp-stream-forms (input &key count) +"Read the contents of the INPUT stream as a list of forms, +and return those forms. + +If COUNT is null, read to the end of the stream; +if COUNT is an integer, stop after COUNT forms were read. + +BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" + (check-type count (or null integer)) + (loop :with eof = '#:eof + :for n :from 0 + :for form = (if (and count (>= n count)) + eof + (read-preserving-whitespace input nil eof)) + :until (eq form eof) :collect form)) + +(defun* slurp-stream-form (input &key (at 0)) +"Read the contents of the INPUT stream as a list of forms, +then return the ACCESS-AT of these forms following the AT. +AT defaults to 0, i.e. return the first form. +AT is typically a list of integers. +If AT is NIL, it will return all the forms in the file. + +The stream will not be read beyond the Nth form, +where N is the index specified by path, +if path is either an integer or a list that starts with an integer. + +BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" + (access-at (slurp-stream-forms input :count (access-at-count at)) at)) + +(defun* read-file-string (file &rest keys) + "Open FILE with option KEYS, read its contents as a string" + (apply 'call-with-input-file file 'slurp-stream-string keys)) + +(defun* read-file-lines (file &rest keys) + "Open FILE with option KEYS, read its contents as a list of lines +BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" + (apply 'call-with-input-file file 'slurp-stream-lines keys)) + +(defun* read-file-forms (file &rest keys &key count &allow-other-keys) + "Open input FILE with option KEYS (except COUNT), +and read its contents as per SLURP-STREAM-FORMS with given COUNT. +BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" + (apply 'call-with-input-file file + #'(lambda (input) (slurp-stream-forms input :count count)) + (remove-plist-key :count keys))) + +(defun* read-file-form (file &rest keys &key (at 0) &allow-other-keys) + "Open input FILE with option KEYS (except AT), +and read its contents as per SLURP-STREAM-FORM with given AT specifier. +BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" + (apply 'call-with-input-file file + #'(lambda (input) (slurp-stream-form input :at at)) + (remove-plist-key :at keys))) + +(defun* safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys) + "Reads the specified form from the top of a file using a safe standardized syntax. +Extracts the form using READ-FILE-FORM, +within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE." + (with-safe-io-syntax (:package package) + (apply 'read-file-form pathname (remove-plist-key :package keys)))) + +(defun* eval-input (input) + "Portably read and evaluate forms from INPUT, return the last values." + (with-input (input) + (loop :with results :with eof ='#:eof + :for form = (read input nil eof) + :until (eq form eof) + :do (setf results (multiple-value-list (eval form))) + :finally (return (apply 'values results))))) + +(defun* eval-thunk (thunk) + "Evaluate a THUNK of code: +If a function, FUNCALL it without arguments. +If a constant literal and not a sequence, return it. +If a cons or a symbol, EVAL it. +If a string, repeatedly read and evaluate from it, returning the last values." + (etypecase thunk + ((or boolean keyword number character pathname) thunk) + ((or cons symbol) (eval thunk)) + (function (funcall thunk)) + (string (eval-input thunk)))) + +(defun* standard-eval-thunk (thunk &key (package :cl)) + "Like EVAL-THUNK, but in a more standardized evaluation context." + ;; Note: it's "standard-" not "safe-", because evaluation is never safe. + (when thunk + (with-safe-io-syntax (:package package) + (let ((*read-eval* t)) + (eval-thunk thunk))))) -(define-condition invalid-configuration () - ((form :reader condition-form :initarg :form) - (location :reader condition-location :initarg :location) - (format :reader condition-format :initarg :format) - (arguments :reader condition-arguments :initarg :arguments :initform nil)) - (:report (lambda (c s) - (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 (compatfmt "~@")))) -(define-condition invalid-output-translation (invalid-configuration warning) - ((format :initform (compatfmt "~@")))) -(defclass component () - ((name :accessor component-name :initarg :name :type string :documentation - "Component name: designator for a string composed of portable pathname characters") - ;; We might want to constrain version with - ;; :type (and string (satisfies parse-version)) - ;; but we cannot until we fix all systems that don't use it correctly! - (version :accessor component-version :initarg :version) - (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 - ;; alists of operations to dependencies (other actions) in each component. - ;; There are two kinds of dependencies, each stored in its own slot: - ;; in-order-to and do-first dependencies. These two kinds are related to - ;; the fact that some actions modify the filesystem, - ;; whereas other actions modify the current image, and - ;; this implies a difference in how to interpret timestamps. - ;; in-order-to dependencies will trigger re-performing the action - ;; when the timestamp of some dependency - ;; makes the timestamp of current action out-of-date; - ;; do-first dependencies do not trigger such re-performing. - ;; Therefore, a FASL must be recompiled if it is obsoleted - ;; by any of its FASL dependencies (in-order-to); but - ;; it needn't be recompiled just because one of these dependencies - ;; hasn't yet been loaded in the current image (do-first). - ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52! - ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively. - ;; Maybe rename the slots in ASDF? But that's not very backwards compatible. - ;; 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 - :accessor component-do-first) - ;; methods defined using the "inline" style inside a defsystem form: - ;; need to store them somewhere so we can delete them when the system - ;; is re-evaluated - (inline-methods :accessor component-inline-methods :initform nil) - (parent :initarg :parent :initform nil :reader component-parent) - ;; no direct accessor for pathname, we do this as a method to allow - ;; it to default in funky ways if not supplied - (relative-pathname :initarg :pathname) - ;; the absolute-pathname is computed based on relative-pathname... - (absolute-pathname) - (operation-times :initform (make-hash-table) - :accessor component-operation-times) - (around-compile :initarg :around-compile) - (%encoding :accessor %component-encoding :initform nil :initarg :encoding) - ;; XXX we should provide some atomic interface for updating the - ;; component properties - (properties :accessor component-properties :initarg :properties - :initform nil))) +;;; Encodings -(defun* component-find-path (component) - (reverse - (loop :for c = component :then (component-parent c) - :while c :collect (component-name c)))) - -(defmethod print-object ((c component) stream) - (print-unreadable-object (c stream :type t :identity nil) - (format stream "~{~S~^ ~}" (component-find-path c)))) - - -;;;; methods: conditions - -(defmethod print-object ((c missing-dependency) s) - (format s (compatfmt "~@<~A, required by ~A~@:>") - (call-next-method c nil) (missing-required-by c))) - -(defun* sysdef-error (format &rest arguments) - (error 'formatted-system-definition-error :format-control - format :format-arguments arguments)) - -;;;; methods: components - -(defmethod print-object ((c missing-component) s) - (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 (compatfmt "~@") - (missing-requires c) - (missing-version c) - (when (missing-parent c) - (coerce-name (missing-parent c))))) - -(defmethod component-system ((component component)) - (aif (component-parent component) - (component-system it) - component)) - -(defvar *default-component-class* 'cl-source-file) - -(defun* compute-module-components-by-name (module) - (let ((hash (make-hash-table :test 'equal))) - (setf (module-components-by-name module) hash) - (loop :for c :in (module-components module) - :for name = (component-name c) - :for previous = (gethash name (module-components-by-name module)) - :do - (when previous - (error 'duplicate-names :name name)) - :do (setf (gethash name (module-components-by-name module)) c)) - hash)) - -(defclass module (component) - ((components - :initform nil - :initarg :components - :accessor module-components) - (components-by-name - :accessor module-components-by-name) - ;; What to do if we can't satisfy a dependency of one of this module's - ;; components. This allows a limited form of conditional processing. - (if-component-dep-fails - :initform :fail - :initarg :if-component-dep-fails - :accessor module-if-component-dep-fails) - (default-component-class - :initform nil - :initarg :default-component-class - :accessor module-default-component-class))) - -(defun* component-parent-pathname (component) - ;; No default anymore (in particular, no *default-pathname-defaults*). - ;; If you force component to have a NULL pathname, you better arrange - ;; for any of its children to explicitly provide a proper absolute pathname - ;; wherever a pathname is actually wanted. - (let ((parent (component-parent component))) - (when parent - (component-pathname parent)))) - -(defmethod component-pathname ((component component)) - (if (slot-boundp component 'absolute-pathname) - (slot-value component 'absolute-pathname) - (let ((pathname - (merge-pathnames* - (component-relative-pathname component) - (pathname-directory-pathname (component-parent-pathname component))))) - (unless (or (null pathname) (absolute-pathname-p pathname)) - (error (compatfmt "~@") - pathname (component-find-path component))) - (setf (slot-value component 'absolute-pathname) pathname) - pathname))) - -(defmethod component-property ((c component) property) - (cdr (assoc property (slot-value c 'properties) :test #'equal))) - -(defmethod (setf component-property) (new-value (c component) property) - (let ((a (assoc property (slot-value c 'properties) :test #'equal))) - (if a - (setf (cdr a) new-value) - (setf (slot-value c 'properties) - (acons property new-value (slot-value c 'properties))))) - new-value) - -(defvar *default-encoding* :default - "Default encoding for source files. -The default value :default preserves the legacy behavior. -A future default might be :utf-8 or :autodetect -reading emacs-style -*- coding: utf-8 -*- specifications, -and falling back to utf-8 or latin1 if nothing is specified.") +(defvar *default-encoding* :default + "Default encoding for source files. +The default value :default preserves the legacy behavior. +A future default might be :utf-8 or :autodetect +reading emacs-style -*- coding: utf-8 -*- specifications, +and falling back to utf-8 or latin1 if nothing is specified.") (defparameter *utf-8-external-format* #+(and asdf-unicode (not clisp)) :utf-8 @@ -1421,16 +2770,13 @@ "Hook for an extension to define a function to automatically detect a file's encoding") (defun* detect-encoding (pathname) - (funcall *encoding-detection-hook* pathname)) - -(defmethod component-encoding ((c component)) - (or (loop :for x = c :then (component-parent x) - :while x :thereis (%component-encoding x)) - (detect-encoding (component-pathname c)))) + (if (and pathname (not (directory-pathname-p pathname)) (probe-file pathname)) + (funcall *encoding-detection-hook* pathname) + *default-encoding*)) (defun* default-encoding-external-format (encoding) (case encoding - (:default :default) ;; for backwards compatibility only. Explicit usage discouraged. + (:default :default) ;; for backward-compatibility only. Explicit usage discouraged. (:utf-8 *utf-8-external-format*) (otherwise (cerror "Continue using :external-format :default" (compatfmt "~@") encoding) @@ -1441,2064 +2787,4257 @@ "Hook for an extension to define a mapping between non-default encodings and implementation-defined external-format's") -(defun encoding-external-format (encoding) +(defun* encoding-external-format (encoding) (funcall *encoding-external-format-hook* encoding)) -(defmethod component-external-format ((c component)) - (encoding-external-format (component-encoding c))) - -(defclass proto-system () ; slots to keep when resetting a system - ;; To preserve identity for all objects, we'd need keep the components slots - ;; but also to modify parse-component-form to reset the recycled objects. - ((name) #|(components) (components-by-names)|#)) - -(defclass system (module proto-system) - (;; 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 - :accessor system-license :initarg :license) - (source-file :initarg :source-file :writer %set-system-source-file) ; upgrade issues on CLISP, CMUCL - (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) +;;;; --------------------------------------------------------------------------- +;;;; Access to the Operating System -;;;; ------------------------------------------------------------------------- -;;;; version-satisfies +(asdf/package:define-package :asdf/os + (:recycle :asdf/os :asdf) + (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/pathname :asdf/stream) + (:export + #:featurep #:os-unix-p #:os-windows-p ;; features + #:getenv #:getenvp ;; environment variables + #:native-namestring #:parse-native-namestring + #:inter-directory-separator #:split-native-pathnames-string + #:getenv-pathname #:getenv-pathnames + #:getenv-absolute-directory #:getenv-absolute-directories + #:implementation-identifier ;; implementation identifier + #:implementation-type #:*implementation-type* + #:operating-system #:architecture #:lisp-version-string + #:hostname #:user-homedir #:lisp-implementation-directory + #:getcwd #:chdir #:call-with-current-directory #:with-current-directory + #:*temporary-directory* #:temporary-directory #:default-temporary-directory + #:setup-temporary-directory + #:call-with-temporary-file #:with-temporary-file)) +(in-package :asdf/os) + +;;; Features +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun* featurep (x &optional (*features* *features*)) + (cond + ((atom x) (and (member x *features*) t)) + ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x)))) + ((eq :or (car x)) (some #'featurep (cdr x))) + ((eq :and (car x)) (every #'featurep (cdr x))) + (t (error "Malformed feature specification ~S" x)))) + + (defun* os-unix-p () + (featurep '(:or :unix :cygwin :darwin))) + + (defun* os-windows-p () + (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32)))) + + (defun* os-genera-p () + (featurep :genera)) + + (defun* detect-os () + (flet ((yes (yes) (pushnew yes *features*)) + (no (no) (setf *features* (remove no *features*)))) + (cond + ((os-unix-p) (yes :os-unix) (no :os-windows)) + ((os-windows-p) (yes :os-windows) (no :os-unix)) + ((os-genera-p) (no :os-unix) (no :os-windows)) + (t (error "Congratulations for trying XCVB on an operating system~%~ +that is neither Unix, nor Windows, nor even Genera.~%Now you port it."))))) -(defmethod version-satisfies ((c component) version) - (unless (and version (slot-boundp c 'version)) - (when version - (warn "Requested version ~S but component ~S has no version" version c)) - (return-from version-satisfies t)) - (version-satisfies (component-version c) version)) + (detect-os)) -(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.345.67\")." - *asdf-version*) +;;;; Environment variables: getting them, and parsing them. -(defun* parse-version (string &optional on-error) - "Parse a version string as a series of natural integers separated by dots. -Return a (non-null) list of integers if the string is valid, NIL otherwise. -If on-error is error, warn, or designates a function of compatible signature, -the function is called with an explanation of what is wrong with the argument. -NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3" - (and - (or (stringp string) - (when on-error - (funcall on-error "~S: ~S is not a string" - 'parse-version string)) nil) - (or (loop :for prev = nil :then c :for c :across string - :always (or (digit-char-p c) - (and (eql c #\.) prev (not (eql prev #\.)))) - :finally (return (and c (digit-char-p c)))) - (when on-error - (funcall on-error "~S: ~S doesn't follow asdf version numbering convention" - 'parse-version string)) nil) - (mapcar #'parse-integer (split-string string :separator ".")))) +(defun* getenv (x) + (declare (ignorable x)) + #+(or abcl clisp ecl xcl) (ext:getenv x) + #+allegro (sys:getenv x) + #+clozure (ccl:getenv x) + #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=)) + #+cormanlisp + (let* ((buffer (ct:malloc 1)) + (cname (ct:lisp-string-to-c-string x)) + (needed-size (win:getenvironmentvariable cname buffer 0)) + (buffer1 (ct:malloc (1+ needed-size)))) + (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size)) + nil + (ct:c-string-to-lisp-string buffer1)) + (ct:free buffer) + (ct:free buffer1))) + #+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)))) + #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x) + #+sbcl (sb-ext:posix-getenv x) + #-(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)) -(defmethod version-satisfies ((cver string) version) - (let ((x (parse-version cver 'warn)) - (y (parse-version version 'warn))) - (labels ((bigger (x y) - (cond ((not y) t) - ((not x) nil) - ((> (car x) (car y)) t) - ((= (car x) (car y)) - (bigger (cdr x) (cdr y)))))) - (and x y (= (car x) (car y)) - (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) +(defun* getenvp (x) + "Predicate that is true if the named variable is present in the libc environment, +then returning the non-empty string value of the variable" + (let ((g (getenv x))) (and (not (emptyp g)) g))) -;;;; ----------------------------------------------------------------- -;;;; Windows shortcut support. Based on: -;;;; -;;;; Jesse Hager: The Windows Shortcut File Format. -;;;; http://www.wotsit.org/list.asp?fc=13 -#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera. -(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)) +;;; Native vs Lisp syntax -(defun* read-null-terminated-string (s) - (with-output-to-string (out) - (loop :for code = (read-byte s) - :until (zerop code) - :do (write-char (code-char code) out)))) +(defun* native-namestring (x) + "From a CL pathname, a return namestring suitable for passing to the operating system" + (when x + (let ((p (pathname x))) + #+clozure (with-pathname-defaults ((root-pathname)) + (ccl:native-translated-namestring p)) ; see ccl bug 978 + #+(or cmu scl) (ext:unix-namestring p nil) + #+sbcl (sb-ext:native-namestring p) + #-(or clozure cmu sbcl scl) + (if (os-unix-p) (unix-namestring p) + (namestring p))))) + +(defun* parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys) + "From a native namestring suitable for use by the operating system, return +a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" + (check-type string (or string null)) + (let* ((pathname + (when string + (with-pathname-defaults ((root-pathname)) + #+clozure (ccl:native-to-pathname string) + #+sbcl (sb-ext:parse-native-namestring string) + #-(or clozure sbcl) + (if (os-unix-p) + (parse-unix-namestring string :ensure-directory ensure-directory) + (parse-namestring string))))) + (pathname + (if ensure-directory + (and pathname (ensure-directory-pathname pathname)) + pathname))) + (apply 'ensure-pathname pathname constraints))) -(defun* read-little-endian (s &optional (bytes 4)) - (loop :for i :from 0 :below bytes - :sum (ash (read-byte s) (* 8 i)))) -(defun* parse-file-location-info (s) - (let ((start (file-position s)) - (total-length (read-little-endian s)) - (end-of-header (read-little-endian s)) - (fli-flags (read-little-endian s)) - (local-volume-offset (read-little-endian s)) - (local-offset (read-little-endian s)) - (network-volume-offset (read-little-endian s)) - (remaining-offset (read-little-endian s))) - (declare (ignore total-length end-of-header local-volume-offset)) - (unless (zerop fli-flags) - (cond - ((logbitp 0 fli-flags) - (file-position s (+ start local-offset))) - ((logbitp 1 fli-flags) - (file-position s (+ start - network-volume-offset - #x14)))) - (strcat (read-null-terminated-string s) - (progn - (file-position s (+ start remaining-offset)) - (read-null-terminated-string s)))))) +;;; Native pathnames in environment +(defun* inter-directory-separator () + (if (os-unix-p) #\: #\;)) +(defun* split-native-pathnames-string (string &rest constraints &key &allow-other-keys) + (loop :for namestring :in (split-string string :separator (string (inter-directory-separator))) + :collect (apply 'parse-native-namestring namestring constraints))) +(defun* getenv-pathname (x &rest constraints &key on-error &allow-other-keys) + (apply 'parse-native-namestring (getenvp x) + :on-error (or on-error + `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x)) + constraints)) +(defun* getenv-pathnames (x &rest constraints &key on-error &allow-other-keys) + (apply 'split-native-pathnames-string (getenvp x) + :on-error (or on-error + `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x)) + constraints)) +(defun* getenv-absolute-directory (x) + (getenv-pathname x :want-absolute t :ensure-directory t)) +(defun* getenv-absolute-directories (x) + (getenv-pathnames x :want-absolute t :ensure-directory t)) -(defun* parse-windows-shortcut (pathname) - (with-open-file (s pathname :element-type '(unsigned-byte 8)) - (handler-case - (when (and (= (read-little-endian s) *link-initial-dword*) - (let ((header (make-array (length *link-guid*)))) - (read-sequence header s) - (equalp header *link-guid*))) - (let ((flags (read-little-endian s))) - (file-position s 76) ;skip rest of header - (when (logbitp 0 flags) - ;; skip shell item id list - (let ((length (read-little-endian s 2))) - (file-position s (+ length (file-position s))))) - (cond - ((logbitp 1 flags) - (parse-file-location-info s)) - (t - (when (logbitp 2 flags) - ;; skip description string - (let ((length (read-little-endian s 2))) - (file-position s (+ length (file-position s))))) - (when (logbitp 3 flags) - ;; finally, our pathname - (let* ((length (read-little-endian s 2)) - (buffer (make-array length))) - (read-sequence buffer s) - (map 'string #'code-char buffer))))))) - (end-of-file () - nil))))) -;;;; ------------------------------------------------------------------------- -;;;; Finding systems +;;;; implementation-identifier +;; +;; produce a string to identify current implementation. +;; Initially stolen from SLIME's SWANK, completely rewritten since. +;; We're back to runtime checking, for the sake of e.g. ABCL. + +(defun* first-feature (feature-sets) + (dolist (x feature-sets) + (multiple-value-bind (short long feature-expr) + (if (consp x) + (values (first x) (second x) (cons :or (rest x))) + (values x x x)) + (when (featurep feature-expr) + (return (values short long)))))) -(defun* make-defined-systems-table () - (make-hash-table :test 'equal)) +(defun* implementation-type () + (first-feature + '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) + (:cmu :cmucl :cmu) :ecl :gcl + (:lwpe :lispworks-personal-edition) (:lw :lispworks) + :mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl))) -(defvar *defined-systems* (make-defined-systems-table) - "This is a hash table whose keys are strings, being the -names of the systems, and whose values are pairs, the first -element of which is a universal-time indicating when the -system definition was last updated, and the second element -of which is a system object.") +(defvar *implementation-type* (implementation-type)) -(defun* coerce-name (name) - (typecase name - (component (component-name name)) - (symbol (string-downcase (symbol-name name))) - (string name) - (t (sysdef-error (compatfmt "~@") name)))) +(defun* operating-system () + (first-feature + '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! + (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd + (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd + (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix + :genera))) -(defun* system-registered-p (name) - (gethash (coerce-name name) *defined-systems*)) +(defun* architecture () + (first-feature + '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386)) + (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target) + (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc) + :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc) + :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach + ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI, + ;; we may have to segregate the code still by architecture. + (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))) -(defun* registered-systems () - (loop :for (() . system) :being :the :hash-values :of *defined-systems* - :collect (coerce-name system))) +#+clozure +(defun* ccl-fasl-version () + ;; the fasl version is target-dependent from CCL 1.8 on. + (or (let ((s 'ccl::target-fasl-version)) + (and (fboundp s) (funcall s))) + (and (boundp 'ccl::fasl-version) + (symbol-value 'ccl::fasl-version)) + (error "Can't determine fasl version."))) -(defun* register-system (system) - (check-type system system) - (let ((name (component-name system))) - (check-type name string) - (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) - (unless (eq system (cdr (gethash name *defined-systems*))) - (setf (gethash name *defined-systems*) - (cons (get-universal-time) system))))) - -(defun* clear-system (name) - "Clear the entry for a system in the database of systems previously loaded. -Note that this does NOT in any way cause the code of the system to be unloaded." - ;; There is no "unload" operation in Common Lisp, and - ;; a general such operation cannot be portably written, - ;; considering how much CL relies on side-effects to global data structures. - (remhash (coerce-name name) *defined-systems*)) - -(defun* map-systems (fn) - "Apply FN to each defined system. +(defun* lisp-version-string () + (let ((s (lisp-implementation-version))) + (car ; as opposed to OR, this idiom prevents some unreachable code warning + (list + #+allegro + (format nil "~A~@[~A~]~@[~A~]~@[~A~]" + excl::*common-lisp-version-number* + ;; 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")) + (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.) + #+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) + #+scl (format nil "~A~A" s + ;; ANSI upper case vs lower case. + (ecase ext:*case-mode* (:upper "") (:lower "l"))) + #+ecl (format nil "~A~@[-~A~]" s + (let ((vcs-id (ext:lisp-implementation-vcs-id))) + (subseq vcs-id 0 (min (length vcs-id) 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)) + #+mcl (subseq s 8) ; strip the leading "Version " + s)))) -FN should be a function of one argument. It will be -called with an object of type asdf:system." - (loop :for (nil . system) :being :the hash-values :of *defined-systems* - :do (funcall fn system))) +(defun* implementation-identifier () + (substitute-if + #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\"")) + (format nil "~(~a~@{~@[-~a~]~}~)" + (or (implementation-type) (lisp-implementation-type)) + (or (lisp-version-string) (lisp-implementation-version)) + (or (operating-system) (software-type)) + (or (architecture) (machine-type))))) -;;; for the sake of keeping things reasonably neat, we adopt a -;;; convention that functions in this list are prefixed SYSDEF- -(defvar *system-definition-search-functions* '()) +;;;; Other system information -(setf *system-definition-search-functions* - (append - ;; Remove known-incompatible sysdef functions from ancient sbcl asdf. - (remove 'contrib-sysdef-search *system-definition-search-functions*) - ;; Tuck our defaults at the end of the list if they were absent. - ;; This is imperfect, in case they were removed on purpose, - ;; but then it will be the responsibility of whoever does that - ;; to upgrade asdf before he does such a thing rather than after. - (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) - '(sysdef-central-registry-search - sysdef-source-registry-search - sysdef-find-asdf)))) +(defun* hostname () + ;; Note: untested on RMCL + #+(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 (symbol-call :excl.osi :gethostname) + #+clisp (first (split-string (machine-instance) :separator " ")) + #+gcl (system:gethostname)) -(defun* search-for-system-definition (system) - (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name))) - (cons 'find-system-if-being-defined - *system-definition-search-functions*))) +(defun* user-homedir () + (truenamize + (pathname-directory-pathname + #+cormanlisp (ensure-directory-pathname (user-homedir-pathname)) + #+mcl (current-user-homedir-pathname) + #-(or cormanlisp mcl) (user-homedir-pathname)))) -(defvar *central-registry* nil -"A list of 'system directory designators' ASDF uses to find systems. +(defun* lisp-implementation-directory (&key truename) + (let ((dir + (ignore-errors + #+clozure #p"ccl:" + #+(or ecl mkcl) #p"SYS:" + #+gcl system::*system-directory* + #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil)) + (funcall it) + (getenv-pathname "SBCL_HOME" :ensure-directory t))))) + (if (and dir truename) + (truename* dir) + dir))) + + +;;; Current directory + +(defun* getcwd () + "Get the current working directory as per POSIX getcwd(3), as a pathname object" + (or #+abcl (parse-native-namestring + (java:jstatic "getProperty" "java.lang.System" "user.dir") :ensure-directory t) + #+allegro (excl::current-directory) + #+clisp (ext:default-directory) + #+clozure (ccl:current-directory) + #+(or cmu scl) (parse-native-namestring + (nth-value 1 (unix:unix-current-directory)) :ensure-directory t) + #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return? + #+ecl (ext:getcwd) + #+gcl (parse-native-namestring ;; this is a joke. Isn't there a better way? + (first (symbol-call :asdf/driver :run-program '("/bin/pwd") :output :lines))) + #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical! + #+lispworks (system:current-directory) + #+mkcl (mk-ext:getcwd) + #+sbcl (parse-native-namestring (sb-unix:posix-getcwd/)) + #+xcl (extensions:current-directory) + (error "getcwd not supported on your implementation"))) + +(defun* chdir (x) + "Change current directory, as per POSIX chdir(2)" + #-(or clisp clozure) (when (pathnamep x) (setf x (native-namestring x))) + (or #+clisp (ext:cd x) + #+clozure (setf (ccl:current-directory) x) + #+cormanlisp (unless (zerop (win32::_chdir x)) + (error "Could not set current directory to ~A" x)) + #+sbcl (symbol-call :sb-posix :chdir x) + (error "chdir not supported on your implementation"))) + +(defun* call-with-current-directory (dir thunk) + (if dir + (let* ((dir (truename (merge-pathnames (pathname-directory-pathname dir)))) + (*default-pathname-defaults* dir) + (cwd (getcwd))) + (chdir dir) + (unwind-protect + (funcall thunk) + (chdir cwd))) + (funcall thunk))) + +(defmacro with-current-directory ((dir) &body body) + "Call BODY while the POSIX current working directory is set to DIR" + `(call-with-current-directory ,dir #'(lambda () , at body))) + + +;;; Using temporary files + +(defun* default-temporary-directory () + (or + (when (os-unix-p) + (or (getenv-pathname "TMPDIR" :ensure-directory t) + (parse-native-namestring "/tmp/"))) + (when (os-windows-p) + (getenv-pathname "TEMP" :ensure-directory t)) + (subpathname (user-homedir) "tmp/"))) + +(defvar *temporary-directory* nil) + +(defun* temporary-directory () + (or *temporary-directory* (default-temporary-directory))) + +(defun setup-temporary-directory () + (setf *temporary-directory* (default-temporary-directory)) + ;; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2.7.0-64.1 + #+(and gcl (not gcl2.6)) (setf system::*tmp-dir* *temporary-directory*)) + +(defun* call-with-temporary-file + (thunk &key + prefix keep (direction :io) + (element-type *default-stream-element-type*) + (external-format :default)) + #+gcl2.6 (declare (ignorable external-format)) + (check-type direction (member :output :io)) + (loop + :with prefix = (or prefix (format nil "~Atmp" (native-namestring (temporary-directory)))) + :for counter :from (random (ash 1 32)) + :for pathname = (pathname (format nil "~A~36R" prefix counter)) :do + ;; TODO: on Unix, do something about umask + ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL + ;; TODO: on Unix, use CFFI and mkstemp -- but the master is precisely meant to not depend on CFFI or on anything! Grrrr. + (with-open-file (stream pathname + :direction direction + :element-type element-type + #-gcl2.6 :external-format #-gcl2.6 external-format + :if-exists nil :if-does-not-exist :create) + (when stream + (return + (if keep + (funcall thunk stream pathname) + (unwind-protect + (funcall thunk stream pathname) + (ignore-errors (delete-file pathname))))))))) + +(defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp) + (pathname (gensym "PATHNAME") pathnamep) + prefix keep direction element-type external-format) + &body body) + "Evaluate BODY where the symbols specified by keyword arguments +STREAM and PATHNAME are bound corresponding to a newly created temporary file +ready for I/O. Unless KEEP is specified, delete the file afterwards." + (check-type stream symbol) + (check-type pathname symbol) + `(flet ((think (,stream ,pathname) + ,@(unless pathnamep `((declare (ignore ,pathname)))) + ,@(unless streamp `((when ,stream (close ,stream)))) + , at body)) + #-gcl (declare (dynamic-extent #'think)) + (call-with-temporary-file + #'think + ,@(when direction `(:direction ,direction)) + ,@(when prefix `(:prefix ,prefix)) + ,@(when keep `(:keep ,keep)) + ,@(when element-type `(:element-type ,element-type)) + ,@(when external-format `(:external-format external-format))))) -A 'system directory designator' is a pathname or an expression -which evaluates to a pathname. For example: +;;;; ------------------------------------------------------------------------- +;;;; Starting, Stopping, Dumping a Lisp image - (setf asdf:*central-registry* - (list '*default-pathname-defaults* - #p\"/home/me/cl/systems/\" - #p\"/usr/share/common-lisp/systems/\")) +(asdf/package:define-package :asdf/image + (:recycle :asdf/image :xcvb-driver) + (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/pathname :asdf/stream :asdf/os) + (:export + #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments* + #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments + #:*lisp-interaction* + #:fatal-conditions #:fatal-condition-p #:handle-fatal-condition + #:call-with-fatal-condition-handler #:with-fatal-condition-handler + #:*image-restore-hook* #:*image-prelude* #:*image-entry-point* + #:*image-postlude* #:*image-dump-hook* + #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-backtrace + #:shell-boolean-exit + #:register-image-restore-hook #:register-image-dump-hook + #:call-image-restore-hook #:call-image-dump-hook + #:initialize-asdf-utilities #:restore-image #:dump-image #:create-image +)) +(in-package :asdf/image) + +(defvar *lisp-interaction* t + "Is this an interactive Lisp environment, or is it batch processing?") + +(defvar *command-line-arguments* nil + "Command-line arguments") + +(defvar *image-dumped-p* nil ; may matter as to how to get to command-line-arguments + "Is this a dumped image? As a standalone executable?") + +(defvar *image-restore-hook* nil + "Functions to call (in reverse order) when the image is restored") + +(defvar *image-prelude* nil + "a form to evaluate, or string containing forms to read and evaluate +when the image is restarted, but before the entry point is called.") + +(defvar *image-entry-point* nil + "a function with which to restart the dumped image when execution is restored from it.") + +(defvar *image-postlude* nil + "a form to evaluate, or string containing forms to read and evaluate +before the image dump hooks are called and before the image is dumped.") + +(defvar *image-dump-hook* nil + "Functions to call (in order) when before an image is dumped") + +(defvar *fatal-conditions* '(error) + "conditions that cause the Lisp image to enter the debugger if interactive, +or to die if not interactive") + + +;;; Exiting properly or im- +(defun* quit (&optional (code 0) (finish-output t)) + "Quits from the Lisp world, with the given exit status if provided. +This is designed to abstract away the implementation specific quit forms." + (when finish-output ;; essential, for ClozureCL, and for standard compliance. + (finish-outputs)) + #+(or abcl xcl) (ext:quit :status code) + #+allegro (excl:exit code :quiet t) + #+clisp (ext:quit code) + #+clozure (ccl:quit code) + #+cormanlisp (win32:exitprocess code) + #+(or cmu scl) (unix:unix-exit code) + #+ecl (si:quit code) + #+gcl (lisp:quit code) + #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code) + #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t) + #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ? + #+mkcl (mk-ext:quit :exit-code code) + #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil)) + (quit (find-symbol* :quit :sb-ext nil))) + (cond + (exit `(,exit :code code :abort (not finish-output))) + (quit `(,quit :unix-status code :recklessly-p (not finish-output))))) + #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) + (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code)) + +(defun* die (code format &rest arguments) + "Die in error with some error message" + (with-safe-io-syntax () + (ignore-errors + (fresh-line *stderr*) + (apply #'format *stderr* format arguments) + (format! *stderr* "~&"))) + (quit code)) + +(defun* raw-print-backtrace (&key (stream *debug-io*) count) + "Print a backtrace, directly accessing the implementation" + (declare (ignorable stream count)) + #+allegro + (let ((*terminal-io* stream) + (*standard-output* stream) + (tpl:*zoom-print-circle* *print-circle*) + (tpl:*zoom-print-level* *print-level*) + (tpl:*zoom-print-length* *print-length*)) + (tpl:do-command "zoom" + :from-read-eval-print-loop nil + :count t + :all t)) + #+clisp + (system::print-backtrace :out stream :limit count) + #+(or clozure mcl) + (let ((*debug-io* stream)) + (ccl:print-call-history :count count :start-frame-number 1) + (finish-output stream)) + #+(or cmucl scl) + (let ((debug:*debug-print-level* *print-level*) + (debug:*debug-print-length* *print-length*)) + (debug:backtrace most-positive-fixnum stream)) + #+ecl + (si::tpl-backtrace) + #+lispworks + (let ((dbg::*debugger-stack* + (dbg::grab-stack nil :how-many (or count most-positive-fixnum))) + (*debug-io* stream) + (dbg:*debug-print-level* *print-level*) + (dbg:*debug-print-length* *print-length*)) + (dbg:bug-backtrace nil)) + #+sbcl + (sb-debug:backtrace + #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum)) + stream)) + +(defun* print-backtrace (&rest keys &key stream count) + (declare (ignore stream count)) + (with-safe-io-syntax (:package :cl) + (let ((*print-readably* nil) + (*print-circle* t) + (*print-miser-width* 75) + (*print-length* nil) + (*print-level* nil) + (*print-pretty* t)) + (ignore-errors (apply 'raw-print-backtrace keys))))) + +(defun* print-condition-backtrace (condition &key (stream *stderr*) count) + ;; We print the condition *after* the backtrace, + ;; for the sake of who sees the backtrace at a terminal. + ;; It is up to the caller to print the condition *before*, with some context. + (print-backtrace :stream stream :count count) + (when condition + (safe-format! stream "~&Above backtrace due to this condition:~%~A~&" + condition))) -This is for backward compatibilily. -Going forward, we recommend new users should be using the source-registry. -") +(defun fatal-condition-p (condition) + (match-any-condition-p condition *fatal-conditions*)) -(defun* featurep (x &optional (features *features*)) +(defun* handle-fatal-condition (condition) + "Depending on whether *LISP-INTERACTION* is set, enter debugger or die" (cond - ((atom x) - (and (member x features) t)) - ((eq :not (car x)) - (assert (null (cddr x))) - (not (featurep (cadr x) features))) - ((eq :or (car x)) - (some #'(lambda (x) (featurep x features)) (cdr x))) - ((eq :and (car x)) - (every #'(lambda (x) (featurep x features)) (cdr x))) + (*lisp-interaction* + (invoke-debugger condition)) (t - (error "Malformed feature specification ~S" x)))) + (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition) + (print-condition-backtrace condition :stream *stderr*) + (die 99 "~A" condition)))) -(defun* os-unix-p () - (featurep '(:or :unix :cygwin :darwin))) +(defun* call-with-fatal-condition-handler (thunk) + (handler-bind (((satisfies fatal-condition-p) #'handle-fatal-condition)) + (funcall thunk))) -(defun* os-windows-p () - (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32)))) +(defmacro with-fatal-condition-handler ((&optional) &body body) + `(call-with-fatal-condition-handler #'(lambda () , at body))) -(defun* probe-asd (name defaults) - (block nil - (when (directory-pathname-p defaults) - (let* ((file (probe-file* (subpathname defaults (strcat name ".asd"))))) - (when file - (return file))) - #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) - (when (os-windows-p) - (let ((shortcut - (make-pathname - :defaults defaults :version :newest :case :local - :name (strcat name ".asd") - :type "lnk"))) - (when (probe-file* shortcut) - (let ((target (parse-windows-shortcut shortcut))) - (when target - (return (pathname target)))))))))) +(defun* shell-boolean-exit (x) + "Quit with a return code that is 0 iff argument X is true" + (quit (if x 0 1))) -(defun* sysdef-central-registry-search (system) - (let ((name (coerce-name system)) - (to-remove nil) - (to-replace nil)) - (block nil - (unwind-protect - (dolist (dir *central-registry*) - (let ((defaults (eval dir))) - (when defaults - (cond ((directory-pathname-p defaults) - (let ((file (probe-asd name defaults))) - (when file - (return file)))) - (t - (restart-case - (let* ((*print-circle* nil) - (message - (format nil - (compatfmt "~@") - system dir defaults))) - (error message)) - (remove-entry-from-registry () - :report "Remove entry from *central-registry* and continue" - (push dir to-remove)) - (coerce-entry-to-directory () - :report (lambda (s) - (format s (compatfmt "~@") - (ensure-directory-pathname defaults) dir)) - (push (cons dir (ensure-directory-pathname defaults)) to-replace)))))))) - ;; cleanup - (dolist (dir to-remove) - (setf *central-registry* (remove dir *central-registry*))) - (dolist (pair to-replace) - (let* ((current (car pair)) - (new (cdr pair)) - (position (position current *central-registry*))) - (setf *central-registry* - (append (subseq *central-registry* 0 position) - (list new) - (subseq *central-registry* (1+ position)))))))))) -(defun* make-temporary-package () - (flet ((try (counter) - (ignore-errors - (make-package (format nil "~A~D" :asdf counter) - :use '(:cl :asdf))))) - (do* ((counter 0 (+ counter 1)) - (package (try counter) (try counter))) - (package package)))) +;;; Using image hooks -(defun* safe-file-write-date (pathname) - ;; If FILE-WRITE-DATE returns NIL, it's possible that - ;; the user or some other agent has deleted an input file. - ;; Also, generated files will not exist at the time planning is done - ;; and calls operation-done-p which calls safe-file-write-date. - ;; So it is very possible that we can't get a valid file-write-date, - ;; 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) (ignore-errors (file-write-date pathname))) - (progn - (when (and pathname *asdf-verbose*) - (warn (compatfmt "~@") - pathname)) - 0))) +(defun* register-image-restore-hook (hook &optional (call-now-p t)) + (register-hook-function '*image-restore-hook* hook call-now-p)) -(defmethod find-system ((name null) &optional (error-p t)) - (declare (ignorable name)) - (when error-p - (sysdef-error (compatfmt "~@")))) +(defun* register-image-dump-hook (hook &optional (call-now-p nil)) + (register-hook-function '*image-dump-hook* hook call-now-p)) -(defmethod find-system (name &optional (error-p t)) - (find-system (coerce-name name) error-p)) +(defun* call-image-restore-hook () + (call-functions (reverse *image-restore-hook*))) -(defvar *systems-being-defined* nil - "A hash-table of systems currently being defined keyed by name, or NIL") -(defvar *systems-being-operated* nil - "A boolean indicating that some systems are being operated on") +(defun* call-image-dump-hook () + (call-functions *image-dump-hook*)) -(defun* find-system-if-being-defined (name) - (when *systems-being-defined* - (gethash (coerce-name name) *systems-being-defined*))) -(defun* call-with-system-definitions (thunk) - (if *systems-being-defined* - (funcall thunk) - (let ((*systems-being-defined* (make-hash-table :test 'equal))) - (funcall thunk)))) +;;; Proper command-line arguments -(defmacro with-system-definitions ((&optional) &body body) - `(call-with-system-definitions #'(lambda () , at body))) +(defun* raw-command-line-arguments () + "Find what the actual command line for this process was." + #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later! + #+allegro (sys:command-line-arguments) ; default: :application t + #+clisp (coerce (ext:argv) 'list) + #+clozure (ccl::command-line-arguments) + #+(or cmu scl) extensions:*command-line-strings* + #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i)) + #+gcl si:*command-args* + #+genera nil + #+lispworks sys:*line-arguments-list* + #+sbcl sb-ext:*posix-argv* + #+xcl system:*argv* + #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks sbcl scl xcl) + (error "raw-command-line-arguments not implemented yet")) + +(defun* command-line-arguments (&optional (arguments (raw-command-line-arguments))) + "Extract user arguments from command-line invocation of current process. +Assume the calling conventions of a generated script that uses -- +if we are not called from a directly executable image." + #+abcl arguments + #-abcl + (let* (#-(or sbcl allegro) + (arguments + (if (eq *image-dumped-p* :executable) + arguments + (member "--" arguments :test 'string-equal)))) + (rest arguments))) + +(defun setup-command-line-arguments () + (setf *command-line-arguments* (command-line-arguments))) + +(defun* restore-image (&key + ((:lisp-interaction *lisp-interaction*) *lisp-interaction*) + ((:restore-hook *image-restore-hook*) *image-restore-hook*) + ((:prelude *image-prelude*) *image-prelude*) + ((:entry-point *image-entry-point*) *image-entry-point*)) + (with-fatal-condition-handler () + (call-image-restore-hook) + (standard-eval-thunk *image-prelude*) + (let ((results (multiple-value-list + (if *image-entry-point* + (call-function *image-entry-point*) + t)))) + (if *lisp-interaction* + (apply 'values results) + (shell-boolean-exit (first results)))))) + + +;;; Dumping an image + +#-(or ecl mkcl) +(defun* dump-image (filename &key output-name executable + ((:postlude *image-postlude*) *image-postlude*) + ((:dump-hook *image-dump-hook*) *image-dump-hook*)) + (declare (ignorable filename output-name executable)) + (setf *image-dumped-p* (if executable :executable t)) + (standard-eval-thunk *image-postlude*) + (call-image-dump-hook) + #-(or clisp clozure cmu lispworks sbcl scl) + (when executable + (error "Dumping an executable is not supported on this implementation! Aborting.")) + #+allegro + (progn + (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000 + (excl:dumplisp :name filename :suppress-allegro-cl-banner t)) + #+clisp + (apply #'ext:saveinitmem filename + :quiet t + :start-package *package* + :keep-global-handlers nil + :executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x + (when executable + (list + ;; :parse-options nil ;--- requires a non-standard patch to clisp. + :norc t :script nil :init-function #'restore-image))) + #+clozure + (ccl:save-application filename :prepend-kernel t + :toplevel-function (when executable #'restore-image)) + #+(or cmu scl) + (progn + (ext:gc :full t) + (setf ext:*batch-mode* nil) + (setf ext::*gc-run-time* 0) + (apply 'ext:save-lisp filename #+cmu :executable #+cmu t + (when executable '(:init-function restore-image :process-command-line nil)))) + #+gcl + (progn + (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t) + (si::save-system filename)) + #+lispworks + (if executable + (lispworks:deliver 'restore-image filename 0 :interface nil) + (hcl:save-image filename :environment nil)) + #+sbcl + (progn + ;;(sb-pcl::precompile-random-code-segments) ;--- it is ugly slow at compile-time (!) when the initial core is a big CLOS program. If you want it, do it yourself + (setf sb-ext::*gc-run-time* 0) + (apply 'sb-ext:save-lisp-and-die filename + :executable t ;--- always include the runtime that goes with the core + (when executable (list :toplevel #'restore-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables + #-(or allegro clisp clozure cmu gcl lispworks sbcl scl) + (die 98 "Can't dump ~S: asdf doesn't support image dumping with ~A.~%" + filename (nth-value 1 (implementation-type)))) + + +#+ecl +(defun create-image (destination object-files + &key kind output-name prologue-code epilogue-code + (prelude () preludep) (entry-point () entry-point-p) build-args) + ;; Is it meaningful to run these in the current environment? + ;; only if we also track the object files that constitute the "current" image, + ;; and otherwise simulate dump-image, including quitting at the end. + ;; (standard-eval-thunk *image-postlude*) (call-image-dump-hook) + (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program)) + (apply 'c::builder + kind (pathname destination) + :lisp-files object-files + :init-name (c::compute-init-name (or output-name destination) :kind kind) + :prologue-code prologue-code + :epilogue-code + `(progn + ,epilogue-code + ,@(when (eq kind :program) + `((setf *image-dumped-p* :executable) + (restore-image ;; default behavior would be (si::top-level) + ,@(when preludep `(:prelude ',prelude)) + ,@(when entry-point-p `(:entry-point ',entry-point)))))) + build-args)) + + +;;; Some universal image restore hooks +(map () 'register-image-restore-hook + '(setup-temporary-directory setup-stderr setup-command-line-arguments)) +;;;; ------------------------------------------------------------------------- +;;;; run-program initially from xcvb-driver. -(defun* load-sysdef (name pathname) - ;; Tries to load system definition with canonical NAME from PATHNAME. - (with-system-definitions () - (let ((package (make-temporary-package))) - (unwind-protect - (handler-bind - ((error #'(lambda (condition) - (error 'load-system-definition-error - :name name :pathname pathname - :condition condition)))) - (let ((*package* package) - (*default-pathname-defaults* - ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. - (pathname-directory-pathname (translate-logical-pathname pathname))) - (external-format (encoding-external-format (detect-encoding pathname)))) - (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") - pathname package) - (load pathname :external-format external-format))) - (delete-package package))))) +(asdf/package:define-package :asdf/run-program + (:recycle :asdf/run-program :xcvb-driver) + (:use :asdf/common-lisp :asdf/utility :asdf/pathname :asdf/stream :asdf/os) + (:export + ;;; Escaping the command invocation madness + #:easy-sh-character-p #:escape-sh-token #:escape-sh-command + #:escape-windows-token #:escape-windows-command + #:escape-token #:escape-command + + ;;; run-program + #:slurp-input-stream + #:run-program + #:subprocess-error + #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process + )) +(in-package :asdf/run-program) + +;;;; ----- Escaping strings for the shell ----- + +(defun* requires-escaping-p (token &key good-chars bad-chars) + "Does this token require escaping, given the specification of +either good chars that don't need escaping or bad chars that do need escaping, +as either a recognizing function or a sequence of characters." + (some + (cond + ((and good-chars bad-chars) + (error "only one of good-chars and bad-chars can be provided")) + ((functionp good-chars) + (complement good-chars)) + ((functionp bad-chars) + bad-chars) + ((and good-chars (typep good-chars 'sequence)) + #'(lambda (c) (not (find c good-chars)))) + ((and bad-chars (typep bad-chars 'sequence)) + #'(lambda (c) (find c bad-chars))) + (t (error "requires-escaping-p: no good-char criterion"))) + token)) + +(defun* escape-token (token &key stream quote good-chars bad-chars escaper) + "Call the ESCAPER function on TOKEN string if it needs escaping as per +REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN, +using STREAM as output (or returning result as a string if NIL)" + (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars) + (with-output (stream) + (apply escaper token stream (when quote `(:quote ,quote)))) + (output-string token stream))) + +(defun* escape-windows-token-within-double-quotes (x &optional s) + "Escape a string token X within double-quotes +for use within a MS Windows command-line, outputing to S." + (labels ((issue (c) (princ c s)) + (issue-backslash (n) (loop :repeat n :do (issue #\\)))) + (loop + :initially (issue #\") :finally (issue #\") + :with l = (length x) :with i = 0 + :for i+1 = (1+ i) :while (< i l) :do + (case (char x i) + ((#\") (issue-backslash 1) (issue #\") (setf i i+1)) + ((#\\) + (let* ((j (and (< i+1 l) (position-if-not + #'(lambda (c) (eql c #\\)) x :start i+1))) + (n (- (or j l) i))) + (cond + ((null j) + (issue-backslash (* 2 n)) (setf i l)) + ((and (< j l) (eql (char x j) #\")) + (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j))) + (t + (issue-backslash n) (setf i j))))) + (otherwise + (issue (char x i)) (setf i i+1)))))) + +(defun* escape-windows-token (token &optional s) + "Escape a string TOKEN within double-quotes if needed +for use within a MS Windows command-line, outputing to S." + (escape-token token :stream s :bad-chars #(#\space #\tab #\") :quote nil + :escaper 'escape-windows-token-within-double-quotes)) + +(defun* escape-sh-token-within-double-quotes (x s &key (quote t)) + "Escape a string TOKEN within double-quotes +for use within a POSIX Bourne shell, outputing to S; +omit the outer double-quotes if key argument :QUOTE is NIL" + (when quote (princ #\" s)) + (loop :for c :across x :do + (when (find c "$`\\\"") (princ #\\ s)) + (princ c s)) + (when quote (princ #\" s))) + +(defun* easy-sh-character-p (x) + (or (alphanumericp x) (find x "+-_.,%@:/"))) + +(defun* escape-sh-token (token &optional s) + "Escape a string TOKEN within double-quotes if needed +for use within a POSIX Bourne shell, outputing to S." + (escape-token token :stream s :quote #\" :good-chars + #'easy-sh-character-p + :escaper 'escape-sh-token-within-double-quotes)) -(defun* locate-system (name) - "Given a system NAME designator, try to locate where to load the system from. -Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME -FOUNDP is true when a system was found, -either a new unregistered one or a previously registered one. -FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is -PATHNAME when not null is a path from where to load the system, -either associated with FOUND-SYSTEM, or with the PREVIOUS system. -PREVIOUS when not null is a previously loaded SYSTEM object of same name. -PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." - (let* ((name (coerce-name name)) - (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk - (previous (cdr in-memory)) - (previous (and (typep previous 'system) previous)) - (previous-time (car in-memory)) - (found (search-for-system-definition name)) - (found-system (and (typep found 'system) found)) - (pathname (or (and (typep found '(or pathname string)) (pathname found)) - (and found-system (system-source-file found-system)) - (and previous (system-source-file previous)))) - (foundp (and (or found-system pathname previous) t))) - (check-type found (or null pathname system)) - (when foundp - (setf pathname (resolve-symlinks* pathname)) - (when (and pathname (not (absolute-pathname-p pathname))) - (setf pathname (ensure-pathname-absolute pathname)) - (when found-system - (%set-system-source-file pathname found-system))) - (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp - (system-source-file previous) pathname))) - (%set-system-source-file pathname previous) - (setf previous-time nil)) - (values foundp found-system pathname previous previous-time)))) +(defun* escape-shell-token (token &optional s) + (cond + ((os-unix-p) (escape-sh-token token s)) + ((os-windows-p) (escape-windows-token token s)))) -(defmethod find-system ((name string) &optional (error-p t)) - (with-system-definitions () - (loop - (restart-case - (multiple-value-bind (foundp found-system pathname previous previous-time) - (locate-system name) - (declare (ignore foundp)) - (when (and found-system (not previous)) - (register-system found-system)) - (when (and pathname - (or (not previous-time) - ;; don't reload if it's already been loaded, - ;; or its filestamp is in the future which means some clock is skewed - ;; and trying to load might cause an infinite loop. - (< previous-time (safe-file-write-date pathname) (get-universal-time)))) - (load-sysdef name pathname)) - (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed - (return - (cond - (in-memory - (when pathname - (setf (car in-memory) (safe-file-write-date pathname))) - (cdr in-memory)) - (error-p - (error 'missing-component :requires name)))))) - (reinitialize-source-registry-and-retry () - :report (lambda (s) - (format s (compatfmt "~@") name)) - (initialize-source-registry)))))) +(defun* escape-command (command &optional s + (escaper 'escape-shell-token)) + "Given a COMMAND as a list of tokens, return a string of the +spaced, escaped tokens, using ESCAPER to escape." + (etypecase command + (string (output-string command s)) + (list (with-output (s) + (loop :for first = t :then nil :for token :in command :do + (unless first (princ #\space s)) + (funcall escaper token s)))))) + +(defun* escape-windows-command (command &optional s) + "Escape a list of command-line arguments into a string suitable for parsing +by CommandLineToArgv in MS Windows" + ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx + ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx + (escape-command command s 'escape-windows-token)) + +(defun* escape-sh-command (command &optional s) + "Escape a list of command-line arguments into a string suitable for parsing +by /bin/sh in POSIX" + (escape-command command s 'escape-sh-token)) + +(defun* escape-shell-command (command &optional stream) + "Escape a command for the current operating system's shell" + (escape-command command stream 'escape-shell-token)) + + +;;;; Slurping a stream, typically the output of another program + +(defgeneric* slurp-input-stream (processor input-stream &key &allow-other-keys)) + +#-(or gcl2.6 genera) +(defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys) + (funcall function input-stream)) + +(defmethod slurp-input-stream ((list cons) input-stream &key &allow-other-keys) + (apply (first list) (cons input-stream (rest list)))) + +#-(or gcl2.6 genera) +(defmethod slurp-input-stream ((output-stream stream) input-stream + &key linewise prefix (element-type 'character) buffer-size &allow-other-keys) + (copy-stream-to-stream + input-stream output-stream + :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) -(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) - (setf fallback (coerce-name fallback) - requested (coerce-name requested)) - (when (equal requested fallback) - (let ((registered (cdr (gethash fallback *defined-systems*)))) - (or registered - (apply 'make-instance 'system - :name fallback :source-file source-file keys))))) - -(defun* sysdef-find-asdf (name) - ;; Bug: :version *asdf-version* won't be updated when ASDF is updated. - (find-system-fallback name "asdf" :version *asdf-version*)) +(defmethod slurp-input-stream ((x (eql 'string)) stream &key &allow-other-keys) + (declare (ignorable x)) + (slurp-stream-string stream)) +(defmethod slurp-input-stream ((x (eql :string)) stream &key &allow-other-keys) + (declare (ignorable x)) + (slurp-stream-string stream)) -;;;; ------------------------------------------------------------------------- -;;;; Finding components +(defmethod slurp-input-stream ((x (eql :lines)) stream &key count &allow-other-keys) + (declare (ignorable x)) + (slurp-stream-lines stream :count count)) -(defmethod find-component ((base string) path) - (let ((s (find-system base nil))) - (and s (find-component s path)))) +(defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0) &allow-other-keys) + (declare (ignorable x)) + (slurp-stream-line stream :at at)) -(defmethod find-component ((base symbol) path) +(defmethod slurp-input-stream ((x (eql :forms)) stream &key count &allow-other-keys) + (declare (ignorable x)) + (slurp-stream-forms stream :count count)) + +(defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0) &allow-other-keys) + (declare (ignorable x)) + (slurp-stream-form stream :at at)) + +(defmethod slurp-input-stream (x stream + &key linewise prefix (element-type 'character) buffer-size + &allow-other-keys) + (declare (ignorable stream linewise prefix element-type buffer-size)) (cond - (base (find-component (coerce-name base) path)) - (path (find-component path nil)) - (t nil))) + #+(or gcl2.6 genera) + ((functionp x) (funcall x stream)) + #+(or gcl2.6 genera) + ((output-stream-p x) + (copy-stream-to-stream + input-stream output-stream + :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) + (t + (error "Invalid ~S destination ~S" 'slurp-input-stream x)))) -(defmethod find-component ((base cons) path) - (find-component (car base) (cons (cdr base) path))) -(defmethod find-component ((module module) (name string)) - (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!! - (compute-module-components-by-name module)) - (values (gethash name (module-components-by-name module)))) +;;;; ----- Running an external program ----- +;;; Simple variant of run-program with no input, and capturing output +;;; On some implementations, may output to a temporary file... + +(define-condition subprocess-error (error) + ((code :initform nil :initarg :code :reader subprocess-error-code) + (command :initform nil :initarg :command :reader subprocess-error-command) + (process :initform nil :initarg :process :reader subprocess-error-process)) + (:report (lambda (condition stream) + (format stream "Subprocess~@[ ~S~]~@[ run with command ~S~] exited with error~@[ code ~D~]" + (subprocess-error-process condition) + (subprocess-error-command condition) + (subprocess-error-code condition))))) + +(defun* run-program (command + &key output ignore-error-status force-shell + (element-type *default-stream-element-type*) + (external-format :default) + &allow-other-keys) + "Run program specified by COMMAND, +either a list of strings specifying a program and list of arguments, +or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows); +have its output processed by the OUTPUT processor function +as per SLURP-INPUT-STREAM, +or merely output to the inherited standard output if it's NIL. +Always call a shell (rather than directly execute the command) +if FORCE-SHELL is specified. +Issue an error if the process wasn't successful unless IGNORE-ERROR-STATUS +is specified. +Return the exit status code of the process that was called. +Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor." + (declare (ignorable ignore-error-status element-type external-format)) + #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl) + (error "RUN-PROGRAM not implemented for this Lisp") + (labels (#+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl) + (run-program (command &key pipe interactive) + "runs the specified command (a list of program and arguments). + If using a pipe, returns two values: process and stream + If not using a pipe, returns one values: the process result; + also, inherits the output stream." + ;; NB: these implementations have unix vs windows set at compile-time. + (assert (not (and pipe interactive))) + (let* ((wait (not pipe)) + #-(and clisp os-windows) + (command + (etypecase command + #+os-unix (string `("/bin/sh" "-c" ,command)) + #+os-unix (list command) + #+os-windows + (string + ;; NB: We do NOT add cmd /c here. You might want to. + #+allegro command + ;; On ClozureCL for Windows, we assume you are using + ;; r15398 or later in 1.9 or later, + ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858 + #+clozure (cons "cmd" (strcat "/c " command)) + ;; NB: On other Windows implementations, this is utterly bogus + ;; except in the most trivial cases where no quoting is needed. + ;; Use at your own risk. + #-(or allegro clozure) (list "cmd" "/c" command)) + #+os-windows + (list + #+(or allegro clozure) (escape-windows-command command) + #-(or allegro clozure) command))) + #+(and clozure os-windows) (command (list command)) + (process* + (multiple-value-list + #+allegro + (excl:run-shell-command + #+os-unix (coerce (cons (first command) command) 'vector) + #+os-windows command + :input interactive :output (or (and pipe :stream) interactive) :wait wait + #+os-windows :show-window #+os-windows (and pipe :hide)) + #+clisp + (flet ((run (f &rest args) + (apply f `(, at args :input ,(when interactive :terminal) :wait ,wait :output + ,(if pipe :stream :terminal))))) + (etypecase command + #+os-windows (run 'ext:run-shell-command command) + (list (run 'ext:run-program (car command) + :arguments (cdr command))))) + #+lispworks + (system:run-shell-command + (cons "/usr/bin/env" command) ; lispworks wants a full path. + :input interactive :output (or (and pipe :stream) interactive) + :wait wait :save-exit-status (and pipe t)) + #+(or clozure cmu ecl sbcl scl) + (#+(or cmu ecl scl) ext:run-program + #+clozure ccl:run-program + #+sbcl sb-ext:run-program + (car command) (cdr command) + :input interactive :wait wait + :output (if pipe :stream t) + . #.(append + #+(or clozure cmu ecl sbcl scl) '(:error t) + ;; note: :external-format requires a recent SBCL + #+sbcl '(:search t :external-format external-format))))) + (process + #+(or allegro lispworks) (if pipe (third process*) (first process*)) + #+ecl (third process*) + #-(or allegro lispworks ecl) (first process*)) + (stream + (when pipe + #+(or allegro lispworks ecl) (first process*) + #+clisp (first process*) + #+clozure (ccl::external-process-output process) + #+(or cmu scl) (ext:process-output process) + #+sbcl (sb-ext:process-output process)))) + (values process stream))) + #+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl) + (process-result (process pipe) + (declare (ignorable pipe)) + ;; 1- wait + #+(and clozure os-unix) (ccl::external-process-wait process) + #+(or cmu scl) (ext:process-wait process) + #+(and ecl os-unix) (ext:external-process-wait process) + #+sbcl (sb-ext:process-wait process) + ;; 2- extract result + #+allegro (if pipe (sys:reap-os-subprocess :pid process :wait t) process) + #+clisp process + #+clozure (nth-value 1 (ccl:external-process-status process)) + #+(or cmu scl) (ext:process-exit-code process) + #+ecl (nth-value 1 (ext:external-process-status process)) + #+lispworks (if pipe (system:pid-exit-status process :wait t) process) + #+sbcl (sb-ext:process-exit-code process)) + (check-result (exit-code process) + #+clisp + (setf exit-code + (typecase exit-code (integer exit-code) (null 0) (t -1))) + (unless (or ignore-error-status + (equal exit-code 0)) + (error 'subprocess-error :command command :code exit-code :process process)) + exit-code) + (use-run-program () + #-(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) + (let* ((interactive (eq output :interactive)) + (pipe (and output (not interactive)))) + (multiple-value-bind (process stream) + (run-program command :pipe pipe :interactive interactive) + (if (and output (not interactive)) + (unwind-protect + (slurp-input-stream output stream) + (when stream (close stream)) + (check-result (process-result process pipe) process)) + (unwind-protect + (check-result + #+(or allegro lispworks) ; when not capturing, returns the exit code! + process + #-(or allegro lispworks) (process-result process pipe) + process)))))) + (system-command (command) + (etypecase command + (string (if (os-windows-p) (format nil "cmd /c ~A" command) command)) + (list (escape-shell-command + (if (os-unix-p) (cons "exec" command) command))))) + (redirected-system-command (command out) + (format nil (if (os-unix-p) "exec > ~*~A ; ~2:*~A" "~A > ~A") + (system-command command) (native-namestring out))) + (system (command &key interactive) + (declare (ignorable interactive)) + #+(or abcl xcl) (ext:run-shell-command command) + #+allegro + (excl:run-shell-command command :input interactive :output interactive :wait t) + #+(or clisp clozure cmu (and lispworks os-unix) sbcl scl) + (process-result (run-program command :pipe nil :interactive interactive) nil) + #+ecl (ext:system command) + #+cormanlisp (win32:system command) + #+gcl (lisp:system command) + #+(and lispworks os-windows) + (system:call-system-showing-output + command :show-cmd interactive :prefix "" :output-stream nil) + #+mcl (ccl::with-cstrs ((%command command)) (_system %command)) + #+mkcl (nth-value 2 + (mkcl:run-program #+windows command #+windows () + #-windows "/bin/sh" (list "-c" command) + :input nil :output nil))) + (call-system (command-string &key interactive) + (check-result (system command-string :interactive interactive) nil)) + (use-system () + (let ((interactive (eq output :interactive))) + (if (and output (not interactive)) + (with-temporary-file (:pathname tmp :direction :output) + (call-system (redirected-system-command command tmp)) + (with-open-file (stream tmp + :direction :input + :if-does-not-exist :error + :element-type element-type + #-gcl2.6 :external-format #-gcl2.6 external-format) + (slurp-input-stream output stream))) + (call-system (system-command command) :interactive interactive))))) + (if (and (not force-shell) + #+(or clisp ecl) ignore-error-status + #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) nil) + (use-run-program) + (use-system)))) -(defmethod find-component ((component component) (name symbol)) - (if name - (find-component component (coerce-name name)) - component)) +;;;; ------------------------------------------------------------------------- +;;;; Support to build (compile and load) Lisp files -(defmethod find-component ((module module) (name cons)) - (find-component (find-component module (car name)) (cdr name))) +(asdf/package:define-package :asdf/lisp-build + (:recycle :asdf/interface :asdf :asdf/lisp-build) + (:use :asdf/common-lisp :asdf/package :asdf/utility + :asdf/pathname :asdf/stream :asdf/os :asdf/image) + (:export + ;; Variables + #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* + #:*output-translation-function* + #:*optimization-settings* #:*previous-optimization-settings* + #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error + #:compile-warned-warning #:compile-failed-warning + #:check-lisp-compile-results #:check-lisp-compile-warnings + #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions* + #:*deferred-warnings* + ;; Functions & Macros + #:get-optimization-settings #:proclaim-optimization-settings + #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions + #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions + #:reify-simple-sexp #:unreify-simple-sexp + #:reify-deferred-warnings #:reify-undefined-warning #:unreify-deferred-warnings + #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings + #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type + #:call-with-asdf-compilation-unit #:with-asdf-compilation-unit + #:current-lisp-file-pathname #:load-pathname + #:lispize-pathname #:compile-file-type #:call-around-hook + #:compile-file* #:compile-file-pathname* + #:load* #:load-from-string #:combine-fasls) + (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body)) +(in-package :asdf/lisp-build) +(defvar *compile-file-warnings-behaviour* + (or #+clisp :ignore :warn) + "How should ASDF react if it encounters a warning when compiling a file? +Valid values are :error, :warn, and :ignore.") -;;; component subclasses +(defvar *compile-file-failure-behaviour* + (or #+(or mkcl sbcl) :error #+clisp :ignore :warn) + "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE) +when compiling a file, which includes any non-style-warning warning. +Valid values are :error, :warn, and :ignore. +Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.") -(defclass source-file (component) - ((type :accessor source-file-explicit-type :initarg :type :initform nil))) -(defclass cl-source-file (source-file) - ((type :initform "lisp"))) -(defclass cl-source-file.cl (cl-source-file) - ((type :initform "cl"))) -(defclass cl-source-file.lsp (cl-source-file) - ((type :initform "lsp"))) -(defclass c-source-file (source-file) - ((type :initform "c"))) -(defclass java-source-file (source-file) - ((type :initform "java"))) -(defclass static-file (source-file) ()) -(defclass doc-file (static-file) ()) -(defclass html-file (doc-file) - ((type :initform "html"))) +;;; Optimization settings -(defmethod source-file-type ((component module) (s module)) - (declare (ignorable component s)) - :directory) -(defmethod source-file-type ((component source-file) (s module)) - (declare (ignorable s)) - (source-file-explicit-type component)) +(defvar *optimization-settings* nil) +(defvar *previous-optimization-settings* nil) +(defun* get-optimization-settings () + "Get current compiler optimization settings, ready to PROCLAIM again" + (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity))) + #-(or clisp clozure cmu ecl sbcl scl) + (warn "xcvb-driver::get-optimization-settings does not support your implementation. Please help me fix that.") + #.`(loop :for x :in settings + ,@(or #+clozure '(:for v :in '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* ccl::*nx-debug* ccl::*nx-cspeed*)) + #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*)) + #+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity))) + :for y = (or #+clisp (gethash x system::*optimize*) + #+(or clozure ecl) (symbol-value v) + #+(or cmu scl) (funcall f c::*default-cookie*) + #+sbcl (cdr (assoc x sb-c::*policy*))) + :when y :collect (list x y)))) +(defun* proclaim-optimization-settings () + "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*" + (proclaim `(optimize ,@*optimization-settings*)) + (let ((settings (get-optimization-settings))) + (unless (equal *previous-optimization-settings* settings) + (setf *previous-optimization-settings* settings)))) -(defmethod component-relative-pathname ((component component)) - (coerce-pathname - (or (slot-value component 'relative-pathname) - (component-name component)) - :type (source-file-type component (component-system component)) - :defaults (component-parent-pathname component))) -;;;; ------------------------------------------------------------------------- -;;;; Operations +;;; Condition control -;;; one of these is instantiated whenever #'operate is called +#+sbcl +(progn + (defun sb-grovel-unknown-constant-condition-p (c) + (and (typep c 'sb-int:simple-style-warning) + (string-enclosed-p + "Couldn't grovel for " + (simple-condition-format-control c) + " (unknown to the C compiler)."))) + (deftype sb-grovel-unknown-constant-condition () + '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p)))) + +(defvar *uninteresting-compiler-conditions* + (append + #+sbcl + `(sb-c::simple-compiler-note + "&OPTIONAL and &KEY found in the same lambda list: ~S" + sb-int:package-at-variance + sb-kernel:uninteresting-redefinition + sb-kernel:undefined-alien-style-warning + ;; sb-ext:implicit-generic-function-warning ; controversial, but let's allow it by default. + sb-kernel:lexical-environment-too-complex + sb-grovel-unknown-constant-condition ; defined above. + ;; BEWARE: the below four are controversial to include here. + sb-kernel:redefinition-with-defun + sb-kernel:redefinition-with-defgeneric + sb-kernel:redefinition-with-defmethod + sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs + ;;#+clozure '(ccl:compiler-warning) + '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop + "Conditions that may be skipped while compiling") + +(defvar *uninteresting-loader-conditions* + (append + '("Overwriting already existing readtable ~S." ;; from named-readtables + #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers + #+clisp '(clos::simple-gf-replacing-method-warning)) + "Additional conditions that may be skipped while loading") + +(defvar *deferred-warnings* () + "Warnings the handling of which is deferred until the end of the compilation unit") + +;;;; ----- Filtering conditions while building ----- + +(defun* call-with-muffled-compiler-conditions (thunk) + (call-with-muffled-conditions + thunk *uninteresting-compiler-conditions*)) +(defmacro with-muffled-compiler-conditions ((&optional) &body body) + "Run BODY where uninteresting compiler conditions are muffled" + `(call-with-muffled-compiler-conditions #'(lambda () , at body))) +(defun* call-with-muffled-loader-conditions (thunk) + (call-with-muffled-conditions + thunk (append *uninteresting-compiler-conditions* *uninteresting-loader-conditions*))) +(defmacro with-muffled-loader-conditions ((&optional) &body body) + "Run BODY where uninteresting compiler and additional loader conditions are muffled" + `(call-with-muffled-loader-conditions #'(lambda () , at body))) + + +;;;; Handle warnings and failures +(define-condition compile-condition (condition) + ((context-format + :initform nil :reader compile-condition-context-format :initarg :context-format) + (context-arguments + :initform nil :reader compile-condition-context-arguments :initarg :context-arguments) + (description + :initform nil :reader compile-condition-description :initarg :description)) + (:report (lambda (c s) + (format s (compatfmt "~@<~A~@[ while ~?~]~@:>") + (or (compile-condition-description c) (type-of c)) + (compile-condition-context-format c) + (compile-condition-context-arguments c))))) +(define-condition compile-file-error (compile-condition error) ()) +(define-condition compile-warned-warning (compile-condition warning) ()) +(define-condition compile-warned-error (compile-condition error) ()) +(define-condition compile-failed-warning (compile-condition warning) ()) +(define-condition compile-failed-error (compile-condition error) ()) + +(defun* check-lisp-compile-warnings (warnings-p failure-p + &optional context-format context-arguments) + (when failure-p + (case *compile-file-failure-behaviour* + (:warn (warn 'compile-failed-warning + :description "Lisp compilation failed" + :context-format context-format + :context-arguments context-arguments)) + (:error (error 'compile-failed-error + :description "Lisp compilation failed" + :context-format context-format + :context-arguments context-arguments)) + (:ignore nil))) + (when warnings-p + (case *compile-file-warnings-behaviour* + (:warn (warn 'compile-warned-warning + :description "Lisp compilation had style-warnings" + :context-format context-format + :context-arguments context-arguments)) + (:error (error 'compile-warned-error + :description "Lisp compilation had style-warnings" + :context-format context-format + :context-arguments context-arguments)) + (:ignore nil)))) + +(defun* check-lisp-compile-results (output warnings-p failure-p + &optional context-format context-arguments) + (unless output + (error 'compile-file-error :context-format context-format :context-arguments context-arguments)) + (check-lisp-compile-warnings warnings-p failure-p context-format context-arguments)) + + +;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman. + +(defun reify-simple-sexp (sexp) + (etypecase sexp + (symbol (reify-symbol sexp)) + ((or number character simple-string pathname) sexp) + (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp)))))) +(defun unreify-simple-sexp (sexp) + (etypecase sexp + ((or symbol number character simple-string pathname) sexp) + (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp)))) + ((simple-vector 2) (unreify-symbol sexp)))) -(defclass operation () - (;; as of danb's 2003-03-16 commit e0d02781, :force can be: - ;; T to force the inside of the specified system, - ;; but not recurse to other systems we depend on. - ;; :ALL (or any other atom) to force all systems - ;; including other systems we depend on. - ;; (SYSTEM1 SYSTEM2 ... SYSTEMN) - ;; to force systems named in a given list - ;; However, but this feature has only ever worked but starting with ASDF 2.014.5 - (forced :initform nil :initarg :force :accessor operation-forced) - (forced-not :initform nil :initarg :force-not :accessor operation-forced-not) - (original-initargs :initform nil :initarg :original-initargs - :accessor operation-original-initargs) - (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes) - (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes) - (parent :initform nil :initarg :parent :accessor operation-parent))) +#+clozure +(progn + (defun reify-source-note (source-note) + (when source-note + (with-accessors ((source ccl::source-note-source) (filename ccl:source-note-filename) + (start-pos ccl:source-note-start-pos) (end-pos ccl:source-note-end-pos)) source-note + (declare (ignorable source)) + (list :filename filename :start-pos start-pos :end-pos end-pos + #|:source (reify-source-note source)|#)))) + (defun unreify-source-note (source-note) + (when source-note + (destructuring-bind (&key filename start-pos end-pos source) source-note + (ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos + :source (unreify-source-note source))))) + (defun reify-deferred-warning (deferred-warning) + (with-accessors ((warning-type ccl::compiler-warning-warning-type) + (args ccl::compiler-warning-args) + (source-note ccl:compiler-warning-source-note) + (function-name ccl:compiler-warning-function-name)) deferred-warning + (list :warning-type warning-type :function-name (reify-simple-sexp function-name) + :source-note (reify-source-note source-note) :args (reify-simple-sexp args)))) + (defun unreify-deferred-warning (reified-deferred-warning) + (destructuring-bind (&key warning-type function-name source-note args) + reified-deferred-warning + (make-condition (or (cdr (ccl::assq warning-type ccl::*compiler-whining-conditions*)) + 'ccl::compiler-warning) + :function-name (unreify-simple-sexp function-name) + :source-note (unreify-source-note source-note) + :warning-type warning-type + :args (unreify-simple-sexp args))))) + +#+sbcl +(defun reify-undefined-warning (warning) + ;; Extracting undefined-warnings from the compilation-unit + ;; To be passed through the above reify/unreify link, it must be a "simple-sexp" + (list* + (sb-c::undefined-warning-kind warning) + (sb-c::undefined-warning-name warning) + (sb-c::undefined-warning-count warning) + (mapcar + #'(lambda (frob) + ;; the lexenv slot can be ignored for reporting purposes + `(:enclosing-source ,(sb-c::compiler-error-context-enclosing-source frob) + :source ,(sb-c::compiler-error-context-source frob) + :original-source ,(sb-c::compiler-error-context-original-source frob) + :context ,(sb-c::compiler-error-context-context frob) + :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname + :file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer + :original-source-path ,(sb-c::compiler-error-context-original-source-path frob))) + (sb-c::undefined-warning-warnings warning)))) + +(defun reify-deferred-warnings () + #+clozure + (mapcar 'reify-deferred-warning + (if-let (dw ccl::*outstanding-deferred-warnings*) + (let ((mdw (ccl::ensure-merged-deferred-warnings dw))) + (ccl::deferred-warnings.warnings mdw)))) + #+sbcl + (when sb-c::*in-compilation-unit* + ;; Try to send nothing through the pipe if nothing needs to be accumulated + `(,@(when sb-c::*undefined-warnings* + `((sb-c::*undefined-warnings* + ,@(mapcar #'reify-undefined-warning sb-c::*undefined-warnings*)))) + ,@(loop :for what :in '(sb-c::*aborted-compilation-unit-count* + sb-c::*compiler-error-count* + sb-c::*compiler-warning-count* + sb-c::*compiler-style-warning-count* + sb-c::*compiler-note-count*) + :for value = (symbol-value what) + :when (plusp value) + :collect `(,what . ,value))))) + +(defun unreify-deferred-warnings (reified-deferred-warnings) + (declare (ignorable reified-deferred-warnings)) + #+clozure + (let ((dw (or ccl::*outstanding-deferred-warnings* + (setf ccl::*outstanding-deferred-warnings* (ccl::%defer-warnings t))))) + (appendf (ccl::deferred-warnings.warnings dw) + (mapcar 'unreify-deferred-warning reified-deferred-warnings))) + #+sbcl + (dolist (item reified-deferred-warnings) + ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol. + ;; For *undefined-warnings*, the adjustment is a list of initargs. + ;; For everything else, it's an integer. + (destructuring-bind (symbol . adjustment) item + (case symbol + ((sb-c::*undefined-warnings*) + (setf sb-c::*undefined-warnings* + (nconc (mapcan + #'(lambda (stuff) + (destructuring-bind (kind name count . rest) stuff + (unless (case kind (:function (fboundp name))) + (list + (sb-c::make-undefined-warning + :name name + :kind kind + :count count + :warnings + (mapcar #'(lambda (x) + (apply #'sb-c::make-compiler-error-context x)) + rest)))))) + adjustment) + sb-c::*undefined-warnings*))) + (otherwise + (set symbol (+ (symbol-value symbol) adjustment))))))) + +(defun reset-deferred-warnings () + #+clozure + (if-let (dw ccl::*outstanding-deferred-warnings*) + (let ((mdw (ccl::ensure-merged-deferred-warnings dw))) + (setf (ccl::deferred-warnings.warnings mdw) nil))) + #+sbcl + (when sb-c::*in-compilation-unit* + (setf sb-c::*undefined-warnings* nil + sb-c::*aborted-compilation-unit-count* 0 + sb-c::*compiler-error-count* 0 + sb-c::*compiler-warning-count* 0 + sb-c::*compiler-style-warning-count* 0 + sb-c::*compiler-note-count* 0))) + +(defun* save-deferred-warnings (warnings-file) + "Save forward reference conditions so they may be issued at a latter time, +possibly in a different process." + (with-open-file (s warnings-file :direction :output :if-exists :supersede) + (with-safe-io-syntax () + (write (reify-deferred-warnings) :stream s :pretty t :readably t) + (terpri s))) + (reset-deferred-warnings)) + +(defun* warnings-file-type (&optional implementation-type) + (case (or implementation-type *implementation-type*) + (:sbcl "sbcl-warnings") + ((:clozure :ccl) "ccl-warnings"))) + +(defun* warnings-file-p (file &optional implementation-type) + (if-let (type (warnings-file-type implementation-type)) + (equal (pathname-type file) type))) + +(defun* check-deferred-warnings (files &optional context-format context-arguments) + (let ((file-errors nil) + (failure-p nil) + (warnings-p nil)) + (handler-bind + ((warning #'(lambda (c) + (setf warnings-p t) + (unless (typep c 'style-warning) + (setf failure-p t))))) + (with-compilation-unit (:override t) + (reset-deferred-warnings) + (dolist (file files) + (unreify-deferred-warnings + (handler-case (safe-read-file-form file) + (error (c) + (delete-file-if-exists file) + (push c file-errors) + nil)))))) + (dolist (error file-errors) (error error)) + (check-lisp-compile-warnings + (or failure-p warnings-p) failure-p context-format context-arguments))) + + +;;;; Deferred warnings +#| +Mini-guide to adding support for deferred warnings on an implementation. + +First, look at what such a warning looks like: + +(describe + (handler-case + (and (eval '(lambda () (some-undefined-function))) nil) + (t (c) c))) + +Then you can grep for the condition type in your compiler sources +and see how to catch those that have been deferred, +and/or read, clear and restore the deferred list. + +ccl:: +undefined-function-reference +verify-deferred-warning +report-deferred-warnings + +|# + +(defun* call-with-saved-deferred-warnings (thunk warnings-file) + (if warnings-file + (with-compilation-unit (:override t) + (let ((*deferred-warnings* ()) + #+sbcl (sb-c::*undefined-warnings* nil)) + (multiple-value-prog1 + (with-muffled-compiler-conditions () + (funcall thunk)) + (save-deferred-warnings warnings-file) + (reset-deferred-warnings)))) + (funcall thunk))) + +(defmacro with-saved-deferred-warnings ((warnings-file) &body body) + "If WARNINGS-FILE is not nil, records the deferred-warnings around the BODY +and saves those warnings to the given file for latter use, +possibly in a different process. Otherwise just run the BODY." + `(call-with-saved-deferred-warnings #'(lambda () , at body) ,warnings-file)) -(defmethod print-object ((o operation) stream) - (print-unreadable-object (o stream :type t :identity t) - (ignore-errors - (prin1 (operation-original-initargs o) stream)))) -(defmethod shared-initialize :after ((operation operation) slot-names - &key force force-not - &allow-other-keys) - ;; the &allow-other-keys disables initarg validity checking - (declare (ignorable operation slot-names force force-not)) - (macrolet ((frob (x) ;; normalize forced and forced-not slots - `(when (consp (slot-value operation ',x)) - (setf (slot-value operation ',x) - (mapcar #'coerce-name (slot-value operation ',x)))))) - (frob forced) (frob forced-not)) - (values)) +;;; from ASDF -(defun* node-for (o c) - (cons (class-name (class-of o)) c)) +(defun* current-lisp-file-pathname () + (or *compile-file-pathname* *load-pathname*)) -(defmethod operation-ancestor ((operation operation)) - (aif (operation-parent operation) - (operation-ancestor it) - operation)) - - -(defun* make-sub-operation (c o dep-c dep-o) - "C is a component, O is an operation, DEP-C is another -component, and DEP-O, confusingly enough, is an operation -class specifier, not an operation." - (let* ((args (copy-list (operation-original-initargs o))) - (force-p (getf args :force))) - ;; note explicit comparison with T: any other non-NIL force value - ;; (e.g. :recursive) will pass through - (cond ((and (null (component-parent c)) - (null (component-parent dep-c)) - (not (eql c dep-c))) - (when (eql force-p t) - (setf (getf args :force) nil)) - (apply 'make-instance dep-o - :parent o - :original-initargs args args)) - ((subtypep (type-of o) dep-o) - o) - (t - (apply 'make-instance dep-o - :parent o :original-initargs args args))))) +(defun* load-pathname () + *load-pathname*) +(defun* lispize-pathname (input-file) + (make-pathname :type "lisp" :defaults input-file)) -(defmethod visit-component ((o operation) (c component) data) - (unless (component-visited-p o c) - (setf (gethash (node-for o c) - (operation-visited-nodes (operation-ancestor o))) - (cons t data)))) - -(defmethod component-visited-p ((o operation) (c component)) - (gethash (node-for o c) - (operation-visited-nodes (operation-ancestor o)))) +(defun* compile-file-type (&rest keys) + "pathname TYPE for lisp FASt Loading files" + (declare (ignorable keys)) + #-(or ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp"))) + #+(or ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys))) -(defmethod (setf visiting-component) (new-value operation component) - ;; MCL complains about unused lexical variables - (declare (ignorable operation component)) - new-value) +(defun* call-around-hook (hook function) + (call-function (or hook 'funcall) function)) -(defmethod (setf visiting-component) (new-value (o operation) (c component)) - (let ((node (node-for o c)) - (a (operation-ancestor o))) - (if new-value - (setf (gethash node (operation-visiting-nodes a)) t) - (remhash node (operation-visiting-nodes a))) - new-value)) - -(defmethod component-visiting-p ((o operation) (c component)) - (let ((node (node-for o c))) - (gethash node (operation-visiting-nodes (operation-ancestor o))))) - -(defmethod component-depends-on ((op-spec symbol) (c component)) - ;; Note: we go from op-spec to operation via make-instance - ;; to allow for specialization through defmethod's, even though - ;; it's a detour in the default case below. - (component-depends-on (make-instance op-spec) c)) +(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) + (let* ((keys + (remove-plist-keys `(#+(and allegro (not (version>= 8 2))) :external-format + ,@(unless output-file '(:output-file))) keys))) + (if (absolute-pathname-p output-file) + ;; what cfp should be doing, w/ mp* instead of mp + (let* ((type (pathname-type (apply 'compile-file-type keys))) + (defaults (make-pathname + :type type :defaults (merge-pathnames* input-file)))) + (merge-pathnames* output-file defaults)) + (funcall *output-translation-function* + (apply 'compile-file-pathname input-file keys))))) + +(defun* (compile-file*) (input-file &rest keys + &key compile-check output-file warnings-file + #+clisp lib-file #+(or ecl mkcl) object-file + &allow-other-keys) + "This function provides a portable wrapper around COMPILE-FILE. +It ensures that the OUTPUT-FILE value is only returned and +the file only actually created if the compilation was successful, +even though your implementation may not do that, and including +an optional call to an user-provided consistency check function COMPILE-CHECK; +it will call this function if not NIL at the end of the compilation +with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE +where TMP-FILE is the name of a temporary output-file. +It also checks two flags (with legacy british spelling from ASDF1), +*COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR* +with appropriate implementation-dependent defaults, +and if a failure (respectively warnings) are reported by COMPILE-FILE +with consider it an error unless the respective behaviour flag +is one of :SUCCESS :WARN :IGNORE. +If WARNINGS-FILE is defined, deferred warnings are saved to that file. +On ECL or MKCL, it creates both the linkable object and loadable fasl files. +On implementations that erroneously do not recognize standard keyword arguments, +it will filter them appropriately." + #+ecl (when (and object-file (equal (compile-file-type) (pathname object-file))) + (format t "Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%" + 'compile-file* output-file object-file) + (rotatef output-file object-file)) + (let* ((keywords (remove-plist-keys + `(:output-file :compile-check :warnings-file + #+clisp :lib-file #+(or ecl mkcl) :object-file + #+gcl2.6 ,@'(:external-format :print :verbose)) keys)) + (output-file + (or output-file + (apply 'compile-file-pathname* input-file :output-file output-file keywords))) + #+ecl + (object-file + (unless (use-ecl-byte-compiler-p) + (or object-file + (compile-file-pathname output-file :type :object)))) + #+mkcl + (object-file + (or object-file + (compile-file-pathname output-file :fasl-p nil))) + (tmp-file (tmpize-pathname output-file)) + #+clisp + (tmp-lib (make-pathname :type "lib" :defaults tmp-file))) + (multiple-value-bind (output-truename warnings-p failure-p) + (with-saved-deferred-warnings (warnings-file) + (or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file keywords) + #+ecl (apply 'compile-file input-file :output-file + (if object-file + (list* object-file :system-p t keywords) + (list* tmp-file keywords))) + #+mkcl (apply 'compile-file input-file + :output-file object-file :fasl-p nil keywords))) + (cond + ((and output-truename + (flet ((check-flag (flag behaviour) + (or (not flag) (member behaviour '(:success :warn :ignore))))) + (and (check-flag failure-p *compile-file-failure-behaviour*) + (check-flag warnings-p *compile-file-warnings-behaviour*))) + (progn + #+(or ecl mkcl) + (when (and #+ecl object-file) + (setf output-truename + (compiler::build-fasl + tmp-file #+ecl :lisp-files #+mkcl :lisp-object-files + (list object-file)))) + (or (not compile-check) + (apply compile-check input-file :output-file tmp-file keywords)))) + (delete-file-if-exists output-file) + (when output-truename + #+clisp (when lib-file (rename-file-overwriting-target tmp-lib lib-file)) + (rename-file-overwriting-target output-truename output-file) + (setf output-truename (truename output-file))) + #+clisp (delete-file-if-exists tmp-lib)) + (t ;; error or failed check + (delete-file-if-exists output-truename) + (setf output-truename nil))) + (values output-truename warnings-p failure-p)))) -(defmethod component-depends-on ((o operation) (c component)) - (cdr (assoc (type-of o) (component-in-order-to c)))) +(defun* load* (x &rest keys &key &allow-other-keys) + (etypecase x + ((or pathname string #-(or allegro clozure gcl2.6 genera) stream) + (apply 'load x + #-gcl2.6 keys #+gcl2.6 (remove-plist-key :external-format keys))) + ;; GCL 2.6, Genera can't load from a string-input-stream + ;; ClozureCL 1.6 can only load from file input stream + ;; Allegro 5, I don't remember but it must have been broken when I tested. + #+(or allegro clozure gcl2.6 genera) + (stream ;; make do this way + (let ((*package* *package*) + (*readtable* *readtable*) + (*load-pathname* nil) + (*load-truename* nil)) + (eval-input x))))) + +(defun* load-from-string (string) + "Portably read and evaluate forms from a STRING." + (with-input-from-string (s string) (load* s))) + +;;; Links FASLs together +(defun* combine-fasls (inputs output) + #-(or allegro clisp clozure cmu lispworks sbcl scl xcl) + (error "~A does not support ~S~%inputs ~S~%output ~S" + (implementation-type) 'combine-fasls inputs output) + #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede) + #+(or allegro clisp cmu sbcl scl xcl) (concatenate-files inputs output) + #+lispworks + (let (fasls) + (unwind-protect + (progn + (loop :for i :in inputs + :for n :from 1 + :for f = (add-pathname-suffix + output (format nil "-FASL~D" n)) + :do #-lispworks-personal-edition (lispworks:copy-file i f) + #+lispworks-personal-edition (concatenate-files (list i) f) + (push f fasls)) + (ignore-errors (lispworks:delete-system :fasls-to-concatenate)) + (eval `(scm:defsystem :fasls-to-concatenate + (:default-pathname ,(pathname-directory-pathname output)) + :members + ,(loop :for f :in (reverse fasls) + :collect `(,(namestring f) :load-only t)))) + (scm:concatenate-system output :fasls-to-concatenate)) + (loop :for f :in fasls :do (ignore-errors (delete-file f))) + (ignore-errors (lispworks:delete-system :fasls-to-concatenate))))) -(defmethod component-self-dependencies ((o operation) (c component)) - (remove-if-not - #'(lambda (x) (member (component-name c) (cdr x) :test #'string=)) - (component-depends-on o c))) - -(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)))) - self-deps) - ;; no previous operations needed? I guess we work with the - ;; original source file, then - (list (component-pathname c))))) +;;;; --------------------------------------------------------------------------- +;;;; Generic support for configuration files -(defmethod input-files ((operation operation) (c module)) - (declare (ignorable operation c)) - nil) +(asdf/package:define-package :asdf/configuration + (:recycle :asdf/configuration :asdf) + (:use :asdf/common-lisp :asdf/utility + :asdf/pathname :asdf/stream :asdf/os :asdf/image) + (:export + #:get-folder-path + #:user-configuration-directories #:system-configuration-directories + #:in-first-directory + #:in-user-configuration-directory #:in-system-configuration-directory + #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory + #:configuration-inheritance-directive-p + #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* + #:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook + #:resolve-location #:location-designator-p #:location-function-p #:*here-directory* + #:resolve-relative-location #:resolve-absolute-location)) +(in-package :asdf/configuration) -(defmethod component-operation-time (o c) - (gethash (type-of o) (component-operation-times c))) +(define-condition invalid-configuration () + ((form :reader condition-form :initarg :form) + (location :reader condition-location :initarg :location) + (format :reader condition-format :initarg :format) + (arguments :reader condition-arguments :initarg :arguments :initform nil)) + (:report (lambda (c s) + (format s (compatfmt "~@<~? (will be skipped)~@:>") + (condition-format c) + (list* (condition-form c) (condition-location c) + (condition-arguments c)))))) -(defmethod operation-done-p ((o operation) (c component)) - (let ((out-files (output-files o c)) - (in-files (input-files o c)) - (op-time (component-operation-time o c))) - (flet ((earliest-out () - (reduce #'min (mapcar #'safe-file-write-date out-files))) - (latest-in () - (reduce #'max (mapcar #'safe-file-write-date in-files)))) - (cond - ((and (not in-files) (not out-files)) - ;; arbitrary decision: an operation that uses nothing to - ;; produce nothing probably isn't doing much. - ;; e.g. operations on systems, modules that have no immediate action, - ;; but are only meaningful through traversed dependencies - t) - ((not out-files) - ;; an operation without output-files is probably meant - ;; for its side-effects in the current image, - ;; assumed to be idem-potent, - ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE. - (and op-time (>= op-time (latest-in)))) - ((not in-files) - ;; an operation with output-files and no input-files - ;; is probably meant for its side-effects on the file-system, - ;; assumed to have to be done everytime. - ;; (I don't think there is any such case in ASDF unless extended) - nil) - (t - ;; an operation with both input and output files is assumed - ;; as computing the latter from the former, - ;; assumed to have been done if the latter are all older - ;; than the former. - ;; e.g. COMPILE-OP of some CL-SOURCE-FILE. - ;; We use >= instead of > to play nice with generated files. - ;; This opens a race condition if an input file is changed - ;; after the output is created but within the same second - ;; of filesystem time; but the same race condition exists - ;; whenever the computation from input to output takes more - ;; 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) - (>= (earliest-out) (latest-in)))))))) +(defun* get-folder-path (folder) + (or ;; this semi-portably implements a subset of the functionality of lispworks' sys:get-folder-path + #+(and lispworks mswindows) (sys:get-folder-path folder) + ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData + (ecase folder + (:local-appdata (getenv-absolute-directory "LOCALAPPDATA")) + (:appdata (getenv-absolute-directory "APPDATA")) + (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA") + (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/")))))) +(defun* user-configuration-directories () + (let ((dirs + `(,@(when (os-unix-p) + (cons + (subpathname* (getenv-absolute-directory "XDG_CONFIG_HOME") "common-lisp/") + (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS") + :collect (subpathname* dir "common-lisp/")))) + ,@(when (os-windows-p) + `(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/") + ,(subpathname* (get-folder-path :appdata) "common-lisp/config/"))) + ,(subpathname (user-homedir) ".config/common-lisp/")))) + (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) + :from-end t :test 'equal))) +(defun* system-configuration-directories () + (cond + ((os-unix-p) '(#p"/etc/common-lisp/")) + ((os-windows-p) + (if-let (it (subpathname* (get-folder-path :common-appdata) "common-lisp/config/")) + (list it))))) -;;; For 1.700 I've done my best to refactor TRAVERSE -;;; by splitting it up in a bunch of functions, -;;; so as to improve the collection and use-detection algorithm. --fare -;;; The protocol is as follows: we pass around operation, dependency, -;;; bunch of other stuff, and a force argument. Return a force flag. -;;; The returned flag is T if anything has changed that requires a rebuild. -;;; The force argument is a list of components that will require a rebuild -;;; if the flag is T, at which point whoever returns the flag has to -;;; mark them all as forced, and whoever recurses again can use a NIL list -;;; as a further argument. - -(defvar *forcing* nil - "This dynamically-bound variable is used to force operations in -recursive calls to traverse.") +(defun* in-first-directory (dirs x &key (direction :input)) + (loop :with fun = (ecase direction + ((nil :input :probe) 'probe-file*) + ((:output :io) 'identity)) + :for dir :in dirs + :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir)))))) -(defgeneric* do-traverse (operation component collect)) +(defun* in-user-configuration-directory (x &key (direction :input)) + (in-first-directory (user-configuration-directories) x :direction direction)) +(defun* in-system-configuration-directory (x &key (direction :input)) + (in-first-directory (system-configuration-directories) x :direction direction)) -(defun* resolve-dependency-name (component name &optional version) - (loop - (restart-case - (return - (let ((comp (find-component (component-parent component) name))) - (unless comp - (error 'missing-dependency - :required-by component - :requires name)) - (when version - (unless (version-satisfies comp version) - (error 'missing-dependency-of-version - :required-by component - :version version - :requires name))) - comp)) - (retry () - :report (lambda (s) - (format s (compatfmt "~@") name)) - :test - (lambda (c) - (or (null c) - (and (typep c 'missing-dependency) - (eq (missing-required-by c) component) - (equal (missing-requires c) name)))))))) +(defun* configuration-inheritance-directive-p (x) + (let ((kw '(:inherit-configuration :ignore-inherited-configuration))) + (or (member x kw) + (and (length=n-p x 1) (member (car x) kw))))) -(defun* resolve-dependency-spec (component dep-spec) - (cond - ((atom dep-spec) - (resolve-dependency-name component dep-spec)) - ;; Structured dependencies --- this parses keywords. - ;; The keywords could conceivably be broken out and cleanly (extensibly) - ;; processed by EQL methods. But for now, here's what we've got. - ((eq :version (first dep-spec)) - ;; https://bugs.launchpad.net/asdf/+bug/527788 - (resolve-dependency-name component (second dep-spec) (third dep-spec))) - ((eq :feature (first dep-spec)) - ;; This particular subform is not documented and - ;; has always been broken in the past. - ;; Therefore no one uses it, and I'm cerroring it out, - ;; after fixing it - ;; See https://bugs.launchpad.net/asdf/+bug/518467 - (cerror "Continue nonetheless." - "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.") - (when (find (second dep-spec) *features* :test 'string-equal) - (resolve-dependency-name component (third dep-spec)))) - (t - (error (compatfmt "~@ ), (:feature ), or .~@:>") dep-spec)))) +(defun* report-invalid-form (reporter &rest args) + (etypecase reporter + (null + (apply 'error 'invalid-configuration args)) + (function + (apply reporter args)) + ((or symbol string) + (apply 'error reporter args)) + (cons + (apply 'apply (append reporter args))))) -(defun* do-one-dep (op c collect dep-op dep-c) - ;; Collects a partial plan for performing dep-op on dep-c - ;; as dependencies of a larger plan involving op and c. - ;; Returns t if this should force recompilation of those who depend on us. - ;; dep-op is an operation class name (not an operation object), - ;; whereas dep-c is a component object.n - (do-traverse (make-sub-operation c op dep-c dep-op) dep-c collect)) - -(defun* do-dep (op c collect dep-op-spec dep-c-specs) - ;; Collects a partial plan for performing dep-op-spec on each of dep-c-specs - ;; as dependencies of a larger plan involving op and c. - ;; Returns t if this should force recompilation of those who depend on us. - ;; dep-op-spec is either an operation class name (not an operation object), - ;; or the magic symbol asdf:feature. - ;; If dep-op-spec is asdf:feature, then the first dep-c-specs is a keyword, - ;; and the plan will succeed if that keyword is present in *feature*, - ;; or fail if it isn't - ;; (at which point c's :if-component-dep-fails will kick in). - ;; If dep-op-spec is an operation class name, - ;; then dep-c-specs specifies a list of sibling component of c, - ;; as per resolve-dependency-spec, such that operating op on c - ;; depends on operating dep-op-spec on each of them. - (cond ((eq dep-op-spec 'feature) - (if (member (car dep-c-specs) *features*) - nil - (error 'missing-dependency - :required-by c - :requires (list :feature (car dep-c-specs))))) - (t - (let ((flag nil)) - (dolist (d dep-c-specs) - (when (do-one-dep op c collect dep-op-spec - (resolve-dependency-spec c d)) - (setf flag t))) - flag)))) - -(defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes - -(defun* do-collect (collect x) - (funcall collect x)) - -(defmethod do-traverse ((operation operation) (c component) collect) - (let ((*forcing* *forcing*) - (flag nil)) ;; return value: must we rebuild this and its dependencies? - (labels - ((update-flag (x) - (orf flag x)) - (dep (op comp) - (update-flag (do-dep operation c collect op comp)))) - ;; Have we been visited yet? If so, just process the result. - (aif (component-visited-p operation c) - (progn - (update-flag (cdr it)) - (return-from do-traverse flag))) - ;; dependencies - (when (component-visiting-p operation c) - (error 'circular-dependency :components (list c))) - (setf (visiting-component operation c) t) - (unwind-protect - (block nil - (when (typep c 'system) ;; systems can be forced or forced-not - (let ((ancestor (operation-ancestor operation))) - (flet ((match? (f) - (and f (or (not (consp f)) ;; T or :ALL - (member (component-name c) f :test #'equal))))) - (cond - ((match? (operation-forced ancestor)) - (setf *forcing* t)) - ((match? (operation-forced-not ancestor)) - (return)))))) - ;; first we check and do all the dependencies for the module. - ;; Operations planned in this loop will show up - ;; in the results, and are consumed below. - (let ((*forcing* nil)) - ;; upstream dependencies are never forced to happen just because - ;; the things that depend on them are.... - (loop - :for (required-op . deps) :in (component-depends-on operation c) - :do (dep required-op deps))) - ;; constituent bits - (let ((module-ops - (when (typep c 'module) - (let ((at-least-one nil) - ;; This is set based on the results of the - ;; dependencies and whether we are in the - ;; context of a *forcing* call... - ;; inter-system dependencies do NOT trigger - ;; building components - (*forcing* - (or *forcing* - (and flag (not (typep c 'system))))) - (error nil)) - (while-collecting (internal-collect) - (dolist (kid (module-components c)) - (handler-case - (update-flag - (do-traverse operation kid #'internal-collect)) - #-genera - (missing-dependency (condition) - (when (eq (module-if-component-dep-fails c) - :fail) - (error condition)) - (setf error condition)) - (:no-error (c) - (declare (ignore c)) - (setf at-least-one t)))) - (when (and (eq (module-if-component-dep-fails c) - :try-next) - (not at-least-one)) - (error error))))))) - (update-flag (or *forcing* (not (operation-done-p operation c)))) - ;; For sub-operations, check whether - ;; the original ancestor operation was forced, - ;; or names us amongst an explicit list of things to force... - ;; except that this check doesn't distinguish - ;; between all the things with a given name. Sigh. - ;; BROKEN! - (when flag - (let ((do-first (cdr (assoc (class-name (class-of operation)) - (component-do-first c))))) - (loop :for (required-op . deps) :in do-first - :do (do-dep operation c collect required-op deps))) - (do-collect collect (vector module-ops)) - (do-collect collect (cons operation c))))) - (setf (visiting-component operation c) nil))) - (visit-component operation c (when flag (incf *visit-count*))) - flag)) - -(defun* flatten-tree (l) - ;; You collected things into a list. - ;; Most elements are just things to collect again. - ;; A (simple-vector 1) indicate that you should recurse into its contents. - ;; This way, in two passes (rather than N being the depth of the tree), - ;; you can collect things with marginally constant-time append, - ;; achieving linear time collection instead of quadratic time. - (while-collecting (c) - (labels ((r (x) - (if (typep x '(simple-vector 1)) - (r* (svref x 0)) - (c x))) - (r* (l) - (map () #'r l))) - (r* l)))) +(defvar *ignored-configuration-form* nil) -(defmethod traverse ((operation operation) (c component)) - (flatten-tree - (while-collecting (collect) - (let ((*visit-count* 0)) - (do-traverse operation c #'collect))))) +(defun* validate-configuration-form (form tag directive-validator + &key location invalid-form-reporter) + (unless (and (consp form) (eq (car form) tag)) + (setf *ignored-configuration-form* t) + (report-invalid-form invalid-form-reporter :form form :location location) + (return-from validate-configuration-form nil)) + (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag) + :for directive :in (cdr form) + :when (cond + ((configuration-inheritance-directive-p directive) + (incf inherit) t) + ((eq directive :ignore-invalid-entries) + (setf ignore-invalid-p t) t) + ((funcall directive-validator directive) + t) + (ignore-invalid-p + nil) + (t + (setf *ignored-configuration-form* t) + (report-invalid-form invalid-form-reporter :form directive :location location) + nil)) + :do (push directive x) + :finally + (unless (= inherit 1) + (report-invalid-form invalid-form-reporter + :arguments (list (compatfmt "~@") + :inherit-configuration :ignore-inherited-configuration))) + (return (nreverse x)))) -(defmethod perform ((operation operation) (c source-file)) - (sysdef-error - (compatfmt "~@") - (class-of operation) (class-of c))) +(defun* validate-configuration-file (file validator &key description) + (let ((forms (read-file-forms file))) + (unless (length=n-p forms 1) + (error (compatfmt "~@~%") + description forms)) + (funcall validator (car forms) :location file))) -(defmethod perform ((operation operation) (c module)) - (declare (ignorable operation c)) - nil) +(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter) + "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will +be applied to the results to yield a configuration form. Current +values of TAG include :source-registry and :output-translations." + (let ((files (sort (ignore-errors + (remove-if + 'hidden-pathname-p + (directory* (make-pathname :name *wild* :type "conf" :defaults directory)))) + #'string< :key #'namestring))) + `(,tag + ,@(loop :for file :in files :append + (loop :with ignore-invalid-p = nil + :for form :in (read-file-forms file) + :when (eq form :ignore-invalid-entries) + :do (setf ignore-invalid-p t) + :else + :when (funcall validator form) + :collect form + :else + :when ignore-invalid-p + :do (setf *ignored-configuration-form* t) + :else + :do (report-invalid-form invalid-form-reporter :form form :location file))) + :inherit-configuration))) -(defmethod mark-operation-done ((operation operation) (c component)) - (setf (gethash (type-of operation) (component-operation-times c)) - (reduce #'max - (cons (get-universal-time) - (mapcar #'safe-file-write-date (input-files operation c)))))) +(defun* resolve-relative-location (x &key ensure-directory wilden) + (ensure-pathname + (etypecase x + (pathname x) + (string (parse-unix-namestring + x :ensure-directory ensure-directory)) + (cons + (if (null (cdr x)) + (resolve-relative-location + (car x) :ensure-directory ensure-directory :wilden wilden) + (let* ((car (resolve-relative-location + (car x) :ensure-directory t :wilden nil))) + (merge-pathnames* + (resolve-relative-location + (cdr x) :ensure-directory ensure-directory :wilden wilden) + car)))) + ((eql :*/) *wild-directory*) + ((eql :**/) *wild-inferiors*) + ((eql :*.*.*) *wild-file*) + ((eql :implementation) + (parse-unix-namestring + (implementation-identifier) :ensure-directory t)) + ((eql :implementation-type) + (parse-unix-namestring + (string-downcase (implementation-type)) :ensure-directory t)) + ((eql :hostname) + (parse-unix-namestring (hostname) :ensure-directory t))) + :wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*)))) + :want-relative t)) -(defmethod perform-with-restarts (operation component) - ;; TOO verbose, especially as the default. Add your own :before method - ;; to perform-with-restart or perform if you want that: - #|(when *asdf-verbose* (explain operation component))|# - (perform operation component)) +(defvar *here-directory* nil + "This special variable is bound to the currect directory during calls to +PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here +directive.") -(defmethod perform-with-restarts :around (operation component) - (loop - (restart-case - (return (call-next-method)) - (retry () - :report - (lambda (s) - (format s (compatfmt "~@") - (operation-description operation component)))) - (accept () - :report - (lambda (s) - (format s (compatfmt "~@") - (operation-description operation component))) - (mark-operation-done operation component) - (return))))) +(defvar *user-cache* nil + "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache") -(defmethod explain ((operation operation) (component component)) - (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") - (operation-description operation component))) +(defun compute-user-cache () + (setf *user-cache* + (flet ((try (x &rest sub) (and x `(,x , at sub)))) + (or + (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation) + (when (os-windows-p) + (try (or (get-folder-path :local-appdata) + (get-folder-path :appdata)) + "common-lisp" "cache" :implementation)) + '(:home ".cache" "common-lisp" :implementation))))) +(register-image-restore-hook 'compute-user-cache) + +(defun* resolve-absolute-location (x &key ensure-directory wilden) + (ensure-pathname + (etypecase x + (pathname x) + (string + (let ((p #-mcl (parse-namestring x) + #+mcl (probe-posix x))) + #+mcl (unless p (error "POSIX pathname ~S does not exist" x)) + (if ensure-directory (ensure-directory-pathname p) p))) + (cons + (return-from resolve-absolute-location + (if (null (cdr x)) + (resolve-absolute-location + (car x) :ensure-directory ensure-directory :wilden wilden) + (merge-pathnames* + (resolve-relative-location + (cdr x) :ensure-directory ensure-directory :wilden wilden) + (resolve-absolute-location + (car x) :ensure-directory t :wilden nil))))) + ((eql :root) + ;; special magic! we return a relative pathname, + ;; but what it means to the output-translations is + ;; "relative to the root of the source pathname's host and device". + (return-from resolve-absolute-location + (let ((p (make-pathname* :directory '(:relative)))) + (if wilden (wilden p) p)))) + ((eql :home) (user-homedir)) + ((eql :here) (resolve-absolute-location + *here-directory* :ensure-directory t :wilden nil)) + ((eql :user-cache) (resolve-absolute-location + *user-cache* :ensure-directory t :wilden nil))) + :wilden (and wilden (not (pathnamep x))) + :want-absolute t)) + +;; Try to override declaration in previous versions of ASDF. +(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean) + (:ensure-directory boolean)) t) resolve-location)) -(defmethod operation-description (operation component) - (format nil (compatfmt "~@<~A on ~A~@:>") - (class-of operation) component)) +(defun* (resolve-location) (x &key ensure-directory wilden directory) + (when directory (setf ensure-directory t)) ;; :directory backward compatibility, until 2014-01-16. + (if (atom x) + (resolve-absolute-location x :ensure-directory ensure-directory :wilden wilden) + (loop* :with (first . rest) = x + :with path = (resolve-absolute-location + first :ensure-directory (and (or ensure-directory rest) t) + :wilden (and wilden (null rest))) + :for (element . morep) :on rest + :for dir = (and (or morep ensure-directory) t) + :for wild = (and wilden (not morep)) + :do (setf path (merge-pathnames* + (resolve-relative-location + element :ensure-directory dir :wilden wild) + path)) + :finally (return path)))) -;;;; ------------------------------------------------------------------------- -;;;; compile-op +(defun* location-designator-p (x) + (flet ((absolute-component-p (c) + (typep c '(or string pathname + (member :root :home :here :user-cache)))) + (relative-component-p (c) + (typep c '(or string pathname + (member :*/ :**/ :*.*.* :implementation :implementation-type))))) + (or (typep x 'boolean) + (absolute-component-p x) + (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x)))))) -(defclass compile-op (operation) - ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) - (on-warnings :initarg :on-warnings :accessor operation-on-warnings - :initform *compile-file-warnings-behaviour*) - (on-failure :initarg :on-failure :accessor operation-on-failure - :initform *compile-file-failure-behaviour*) - (flags :initarg :flags :accessor compile-op-flags - :initform nil))) - -(defun* output-file (operation component) - "The unique output file of performing OPERATION on COMPONENT" - (let ((files (output-files operation component))) - (assert (length=n-p files 1)) - (first files))) - -(defun* ensure-all-directories-exist (pathnames) - (dolist (pathname pathnames) - (ensure-directories-exist (translate-logical-pathname pathname)))) - -(defmethod perform :before ((operation compile-op) (c source-file)) - (ensure-all-directories-exist (output-files operation c))) - -(defmethod perform :after ((operation operation) (c component)) - (mark-operation-done operation c)) - -(defgeneric* around-compile-hook (component)) -(defgeneric* call-with-around-compile-hook (component thunk)) - -(defmethod around-compile-hook ((c component)) - (cond - ((slot-boundp c 'around-compile) - (slot-value c 'around-compile)) - ((component-parent c) - (around-compile-hook (component-parent c))))) - -(defun ensure-function (fun &key (package :asdf)) - (etypecase fun - ((or symbol function) fun) - (cons (eval `(function ,fun))) - (string (eval `(function ,(with-standard-io-syntax - (let ((*package* (find-package package))) - (read-from-string fun)))))))) - -(defun call-around-hook (hook function) - (funcall (or (ensure-function hook) 'funcall) function)) - -(defmethod call-with-around-compile-hook ((c component) function) - (call-around-hook (around-compile-hook c) function)) - -;;; 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)) - (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. - (output-file (first (output-files operation c))) - (*compile-file-warnings-behaviour* (operation-on-warnings operation)) - (*compile-file-failure-behaviour* (operation-on-failure operation))) - (multiple-value-bind (output warnings-p failure-p) - (call-with-around-compile-hook - c #'(lambda (&rest flags) - (apply *compile-op-compile-file-function* source-file - :output-file output-file - :external-format (component-external-format c) - (append flags (compile-op-flags operation))))) - (unless output - (error 'compile-error :component c :operation operation)) - (when failure-p - (case (operation-on-failure operation) - (:warn (warn - (compatfmt "~@") - operation c)) - (:error (error 'compile-failed :component c :operation operation)) - (:ignore nil))) - (when warnings-p - (case (operation-on-warnings operation) - (:warn (warn - (compatfmt "~@") - operation c)) - (:error (error 'compile-warned :component c :operation operation)) - (:ignore nil)))))) - -(defmethod output-files ((operation compile-op) (c cl-source-file)) - (declare (ignorable operation)) - (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)) - nil) - -(defmethod output-files ((operation compile-op) (c static-file)) - (declare (ignorable operation c)) - nil) - -(defmethod input-files ((operation compile-op) (c static-file)) - (declare (ignorable operation c)) - nil) +(defun* location-function-p (x) + (and + (length=n-p x 2) + (eq (car x) :function) + (or (symbolp (cadr x)) + (and (consp (cadr x)) + (eq (caadr x) 'lambda) + (length=n-p (cadadr x) 2))))) -(defmethod operation-description ((operation compile-op) component) - (declare (ignorable operation)) - (format nil (compatfmt "~@") component)) +(defvar *clear-configuration-hook* '()) -(defmethod operation-description ((operation compile-op) (component module)) - (declare (ignorable operation)) - (format nil (compatfmt "~@") component)) +(defun* register-clear-configuration-hook (hook-function &optional call-now-p) + (register-hook-function '*clear-configuration-hook* hook-function call-now-p)) +(defun* clear-configuration () + (call-functions *clear-configuration-hook*)) +(register-image-dump-hook 'clear-configuration) ;;;; ------------------------------------------------------------------------- -;;;; load-op - -(defclass basic-load-op (operation) ()) - -(defclass load-op (basic-load-op) ()) - -(defmethod perform-with-restarts ((o load-op) (c cl-source-file)) - (loop - (restart-case - (return (call-next-method)) - (try-recompiling () - :report (lambda (s) - (format s "Recompile ~a and try loading it again" - (component-name c))) - (perform (make-sub-operation c o c 'compile-op) c))))) - -(defmethod perform ((o load-op) (c cl-source-file)) - (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)) - nil) - -(defmethod operation-done-p ((operation load-op) (c static-file)) - (declare (ignorable operation c)) - t) - -(defmethod output-files ((operation operation) (c component)) - (declare (ignorable operation c)) - nil) +;;; Hacks for backward-compatibility of the driver -(defmethod component-depends-on ((operation load-op) (c component)) - (declare (ignorable operation)) - (cons (list 'compile-op (component-name c)) - (call-next-method))) +(asdf/package:define-package :asdf/backward-driver + (:recycle :asdf/backward-driver :asdf) + (:use :asdf/common-lisp :asdf/package :asdf/utility + :asdf/pathname :asdf/stream :asdf/os :asdf/image + :asdf/run-program :asdf/lisp-build + :asdf/configuration) + (:export + #:coerce-pathname #:component-name-to-pathname-components + #+(or ecl mkcl) #:compile-file-keeping-object + )) +(in-package :asdf/backward-driver) -(defmethod operation-description ((operation load-op) component) - (declare (ignorable operation)) - (format nil (compatfmt "~@") - component)) +;;;; Backward compatibility with various pathname functions. -(defmethod operation-description ((operation load-op) (component cl-source-file)) - (declare (ignorable operation)) - (format nil (compatfmt "~@") - component)) +(defun* coerce-pathname (name &key type defaults) + ;; For backward-compatibility only, for people using internals + ;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb + ;; Will be removed after 2014-01-16. + ;;(warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE-UNIX-NAMESTRING.") + (parse-unix-namestring name :type type :defaults defaults)) + +(defun* component-name-to-pathname-components (unix-style-namestring + &key force-directory force-relative) + ;; Will be removed after 2014-01-16. + ;; (warn "Please don't use ASDF::COMPONENT-NAME-TO-PATHNAME-COMPONENTS, use SPLIT-UNIX-NAMESTRING-DIRECTORY-COMPONENTS") + (multiple-value-bind (relabs path filename file-only) + (split-unix-namestring-directory-components + unix-style-namestring :ensure-directory force-directory) + (declare (ignore file-only)) + (when (and force-relative (not (eq relabs :relative))) + (error (compatfmt "~@") + unix-style-namestring)) + (values relabs path filename))) -(defmethod operation-description ((operation load-op) (component module)) - (declare (ignorable operation)) - (format nil (compatfmt "~@") - component)) +#+(or ecl mkcl) +(defun* compile-file-keeping-object (&rest args) (apply #'compile-file* args)) +;;;; --------------------------------------------------------------------------- +;;;; Re-export all the functionality in asdf/driver +(asdf/package:define-package :asdf/driver + (:nicknames :d :asdf-driver :asdf-utils) + (:use :asdf/common-lisp :asdf/package :asdf/utility + :asdf/pathname :asdf/stream :asdf/os :asdf/image + :asdf/run-program :asdf/lisp-build + :asdf/configuration :asdf/backward-driver) + (:reexport + ;; NB: excluding asdf/common-lisp + ;; which include all of CL with compatibility modifications on select platforms. + :asdf/package :asdf/utility + :asdf/pathname :asdf/stream :asdf/os :asdf/image + :asdf/run-program :asdf/lisp-build + :asdf/configuration)) ;;;; ------------------------------------------------------------------------- -;;;; load-source-op - -(defclass load-source-op (basic-load-op) ()) - -(defmethod perform ((o load-source-op) (c cl-source-file)) - (declare (ignorable o)) - (let ((source (component-pathname c))) - (setf (component-property c 'last-loaded-as-source) - (and (call-with-around-compile-hook - c #'(lambda () (load source :external-format (component-external-format c)))) - (get-universal-time))))) - -(defmethod perform ((operation load-source-op) (c static-file)) - (declare (ignorable operation c)) - nil) - -(defmethod output-files ((operation load-source-op) (c component)) - (declare (ignorable operation c)) - nil) - -;;; FIXME: We simply copy load-op's dependencies. This is Just Not Right. -(defmethod component-depends-on ((o load-source-op) (c component)) - (declare (ignorable o)) - (loop :with what-would-load-op-do = (component-depends-on 'load-op c) - :for (op . co) :in what-would-load-op-do - :when (eq op 'load-op) :collect (cons 'load-source-op co))) - -(defmethod operation-done-p ((o load-source-op) (c source-file)) - (declare (ignorable o)) - (and (component-property c 'last-loaded-as-source) - (<= (safe-file-write-date (component-pathname c)) - (component-property c 'last-loaded-as-source)))) - -(defmethod operation-description ((operation load-source-op) component) - (declare (ignorable operation)) - (format nil (compatfmt "~@") - component)) - -(defmethod operation-description ((operation load-source-op) (component module)) - (declare (ignorable operation)) - (format nil (compatfmt "~@") component)) +;;;; Handle upgrade as forward- and backward-compatibly as possible +;; See https://bugs.launchpad.net/asdf/+bug/485687 +(asdf/package:define-package :asdf/upgrade + (:recycle :asdf/upgrade :asdf) + (:use :asdf/common-lisp :asdf/package :asdf/utility) + (:export + #:upgrade-asdf #:asdf-upgrade-error #:when-upgrade + #:*asdf-upgrade-already-attempted* + #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf + #:asdf-version #:*upgraded-p* #:*asdf-version* + #:asdf-message #:*asdf-verbose* #:*verbose-out* + ;; There will be no symbol left behind! + #:intern*) + (:import-from :asdf/package #:intern* #:find-symbol*)) +(in-package :asdf/upgrade) -;;;; ------------------------------------------------------------------------- -;;;; test-op - -(defclass test-op (operation) ()) +;;; Special magic to detect if this is an upgrade -(defmethod perform ((operation test-op) (c component)) - (declare (ignorable operation c)) - nil) +(eval-when (:load-toplevel :compile-toplevel :execute) + (defvar *asdf-version* nil) + (defvar *upgraded-p* nil) + (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12. + (defvar *verbose-out* nil) + (defun* asdf-message (format-string &rest format-args) + (apply 'format *verbose-out* format-string format-args))) -(defmethod operation-done-p ((operation test-op) (c system)) - "Testing a system is _never_ done." - (declare (ignorable operation c)) - nil) +(eval-when (:load-toplevel :compile-toplevel :execute) + (let* (;; For bug reporting sanity, please always bump this version when you modify this file. + ;; Please also modify asdf.asd to reflect this change. make 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.26.143.1") + (existing-asdf (find-class (find-symbol* :component :asdf nil) nil)) + (existing-version *asdf-version*) + (already-there (equal asdf-version existing-version)) + (redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops. + '(#:component-relative-pathname #:component-parent-pathname ;; component + #:source-file-type + #:find-system #:system-source-file #:system-relative-pathname ;; system + #:find-component ;; find-component + #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action + #:component-depends-on #:component-self-dependencies #:operation-done-p + #:traverse ;; plan + #:operate ;; operate + #:apply-output-translations ;; output-translations + #:process-output-translations-directive + #:inherit-source-registry #:process-source-registry ;; source-registry + #:process-source-registry-directive + #:trivial-system-p ;; bundle + ;; NB: it's too late to do anything about asdf-driver functions! + )) + (uninterned-symbols + '(#:*asdf-revision* #:around #:asdf-method-combination + #:split #:make-collector #:do-dep #:do-one-dep + #:resolve-relative-location-component #:resolve-absolute-location-component + #:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function + (declare (ignorable redefined-functions uninterned-symbols)) + (setf *asdf-version* asdf-version) + (when (and existing-asdf (not already-there)) + (push existing-version *upgraded-p*) + (when *asdf-verbose* + (format *trace-output* + (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") + existing-version asdf-version)) + (loop :for name :in (append #-(or clisp ecl) redefined-functions) + :for sym = (find-symbol* name :asdf nil) :do + (when sym + ;;(format t "Undefining ~S~%" sym);XXX + (fmakunbound sym))) + (loop :with asdf = (find-package :asdf) + :for name :in (append #+(or clisp ecl) redefined-functions uninterned-symbols) ;XXX + :for sym = (find-symbol* name :asdf nil) + :for base-pkg = (and sym (symbol-package sym)) :do + (when sym + ;;(format t "frobbing symbol ~S~%" sym);XXX + (cond + ((or (eq base-pkg asdf) (not base-pkg)) + (unintern* sym asdf) + (intern* sym asdf)) + (t + (unintern* sym base-pkg) + (let ((new (intern* sym base-pkg))) + (shadowing-import new asdf)))))) + ;; Note that this massive package destruction makes it impossible + ;; to use asdf/driver on top of an old ASDF on these implementations + #+(or xcl) + (let ((p (find-package :asdf))) + (when p + (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))) + (rename-package-away p :prefix (format nil "~A-~A" :asdf (or existing-version :1.x)) + :index 0 :separator "-")))))) + + +;;; Upgrade interface + +(defun* asdf-upgrade-error () + ;; Important notice for whom it concerns. The crux of the matter is that + ;; TRAVERSE can be completely refactored, and so after the find-system returns, it's too late. + (error "When a system transitively depends on ASDF, it must :defsystem-depends-on (:asdf)~%~ + Otherwise, when you upgrade ASDF, you must do it before you operate on any system.~%")) + +(defmacro when-upgrade ((&key (upgraded-p '*upgraded-p*) when) &body body) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (when (and ,upgraded-p ,@(when when `(,when))) + (handler-bind ((style-warning #'muffle-warning)) + (eval '(progn , at body)))))) -(defmethod component-depends-on :around ((o test-op) (c system)) - (declare (ignorable o)) - (cons `(load-op ,(component-name c)) (call-next-method))) +(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.345.67\")." + *asdf-version*) -;;;; ------------------------------------------------------------------------- -;;;; Invoking Operations +;;; Self-upgrade functions -(defgeneric* operate (operation-class system &key &allow-other-keys)) -(defgeneric* perform-plan (plan &key)) -(defgeneric* plan-operates-on-p (plan component)) +(defvar *post-upgrade-cleanup-hook* ()) +(defvar *post-upgrade-restart-hook* ()) -;;;; Separating this into a different function makes it more forward-compatible (defun* cleanup-upgraded-asdf (old-version) (let ((new-version (asdf-version))) (unless (equal old-version new-version) (cond - ((version-satisfies new-version old-version) + ((version-compatible-p new-version old-version) (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") old-version new-version)) - ((version-satisfies old-version new-version) + ((version-compatible-p old-version new-version) (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") old-version new-version)) (t (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") old-version new-version))) - (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf))) - ;; Invalidate all systems but ASDF itself. - (setf *defined-systems* (make-defined-systems-table)) - (register-system asdf) - ;; If we're in the middle of something, restart it. - (when *systems-being-defined* - (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name))) - (clrhash *systems-being-defined*) - (dolist (s l) (find-system s nil)))) - t)))) + (dolist (h (reverse *post-upgrade-cleanup-hook*)) + (funcall (ensure-function h))) + (dolist (h *post-upgrade-restart-hook*) + (funcall (ensure-function h))) + t))) -;;;; Try to upgrade of ASDF. If a different version was used, return T. -;;;; We need do that before we operate on anything that depends on ASDF. (defun* upgrade-asdf () - (let ((version (asdf-version))) + "Try to upgrade of ASDF. If a different version was used, return T. + We need do that before we operate on anything that may possibly depend on ASDF." + (let ((version (asdf-version)) + (*load-print* nil) + (*compile-print* nil)) (handler-bind (((or style-warning warning) #'muffle-warning)) - (operate 'load-op :asdf :verbose nil)) + (symbol-call :asdf :load-system :asdf :verbose nil)) (cleanup-upgraded-asdf version))) +;;;; ------------------------------------------------------------------------- +;;;; Components -(defmethod plan-operates-on-p ((plan list) (component-path list)) - (find component-path (mapcar 'cdr plan) - :test 'equal :key 'component-find-path)) - -(defmethod perform-plan ((steps list) &key) - (let ((*package* *package*) - (*readtable* *readtable*)) - (with-compilation-unit () - (loop :for (op . component) :in steps :do - (perform-with-restarts op component))))) - -(defmethod operate (operation-class system &rest args - &key force force-not verbose version &allow-other-keys) - (declare (ignore force force-not)) - (with-system-definitions () - (let* ((*asdf-verbose* verbose) - (*verbose-out* (if verbose *standard-output* (make-broadcast-stream))) - (op (apply 'make-instance operation-class - :original-initargs args args)) - (system (etypecase system - (system system) - ((or string symbol) (find-system system)))) - (systems-being-operated *systems-being-operated*) - (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))) - (check-type system system) - (setf (gethash (coerce-name system) *systems-being-operated*) system) - (flet ((upgrade () - ;; If we needed to upgrade ASDF to achieve our goal, - ;; then do it specially as the first thing, - ;; which will invalidate all existing systems; - ;; afterwards, retry the whole thing with the new OPERATE function, - ;; which on some implementations - ;; has a new symbol shadowing the current one. - (unless (gethash "asdf" *systems-being-operated*) - (upgrade-asdf) - (return-from operate - (apply (find-symbol* 'operate :asdf) operation-class system args))))) - (when systems-being-operated ;; Upgrade if loading a system from another one. - (upgrade)) - (unless (version-satisfies system version) - (error 'missing-component-of-version :requires system :version version)) - (let ((plan (traverse op system))) - (when (plan-operates-on-p plan '("asdf")) - (upgrade)) ;; Upgrade early if the plan involves upgrading asdf at any time. - (perform-plan plan) - (values op plan)))))) +(asdf/package:define-package :asdf/component + (:recycle :asdf/component :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade) + (:export + #:component #:component-find-path + #:component-name #:component-pathname #:component-relative-pathname + #:component-parent #:component-system #:component-parent-pathname + #:child-component #:parent-component #:module + #:file-component + #:source-file #:c-source-file #:java-source-file + #:static-file #:doc-file #:html-file + #:source-file-type ;; backward-compatibility + #:component-in-order-to #:component-sibling-dependencies + #:component-if-feature #:around-compile-hook + #:component-description #:component-long-description + #:component-version #:version-satisfies + #:component-properties #:component-property ;; backward-compatibility only. DO NOT USE! + #:component-inline-methods ;; backward-compatibility only. DO NOT USE! + #:component-operation-times ;; For internal use only. + ;; portable ASDF encoding and implementation-specific external-format + #:component-external-format #:component-encoding + #:component-children-by-name #:component-children #:compute-children-by-name + #:component-build-operation + #:module-default-component-class + #:module-components ;; backward-compatibility. DO NOT USE. + + ;; Internals we'd like to share with the ASDF package, especially for upgrade purposes + #:name #:version #:description #:long-description #:author #:maintainer #:licence + #:components-by-name #:components + #:children #:children-by-name #:default-component-class + #:author #:maintainer #:licence #:source-file #:defsystem-depends-on + #:sibling-dependencies #:if-feature #:in-order-to #:inline-methods + #:relative-pathname #:absolute-pathname #:operation-times #:around-compile + #:%encoding #:properties #:parent)) +(in-package :asdf/component) -(defun* oos (operation-class system &rest args - &key force force-not verbose version &allow-other-keys) - (declare (ignore force force-not verbose version)) - (apply 'operate operation-class system args)) +(defgeneric* component-name (component) + (:documentation "Name of the COMPONENT, unique relative to its parent")) +(defgeneric* component-system (component) + (:documentation "Find the top-level system containing COMPONENT")) +(defgeneric* component-pathname (component) + (:documentation "Extracts the pathname applicable for a particular component.")) +(defgeneric* (component-relative-pathname) (component) + (:documentation "Returns a pathname for the component argument intended to be +interpreted relative to the pathname of that component's parent. +Despite the function's name, the return value may be an absolute +pathname, because an absolute pathname may be interpreted relative to +another pathname in a degenerate way.")) +(defgeneric* component-property (component property)) +#-gcl2.6 +(defgeneric* (setf component-property) (new-value component property)) +(defgeneric* component-external-format (component)) +(defgeneric* component-encoding (component)) +(defgeneric* version-satisfies (component version)) -(let ((operate-docstring - "Operate does three things: +;;; Backward compatible way of computing the FILE-TYPE of a component. +;;; TODO: find users, have them stop using that. +(defgeneric* (source-file-type) (component system)) + +(when-upgrade (:when (find-class 'component nil)) + (defmethod reinitialize-instance :after ((c component) &rest initargs &key) + (declare (ignorable c initargs)) (values))) -1. It creates an instance of OPERATION-CLASS using any keyword parameters -as initargs. -2. It finds the asdf-system specified by SYSTEM (possibly loading -it from disk). -3. It then calls TRAVERSE with the operation and system as arguments +(defclass component () + ((name :accessor component-name :initarg :name :type string :documentation + "Component name: designator for a string composed of portable pathname characters") + ;; We might want to constrain version with + ;; :type (and string (satisfies parse-version)) + ;; but we cannot until we fix all systems that don't use it correctly! + (version :accessor component-version :initarg :version) + (description :accessor component-description :initarg :description) + (long-description :accessor component-long-description :initarg :long-description) + (sibling-dependencies :accessor component-sibling-dependencies :initform nil) + (if-feature :accessor component-if-feature :initform nil :initarg :if-feature) + ;; In the ASDF object model, dependencies exist between *actions* + ;; (an action is a pair of operation and component). + ;; Dependencies are represented as alists of operations + ;; to dependencies (other actions) in each component. + ;; Up until ASDF 2.26.9, there used to be two kinds of dependencies: + ;; in-order-to and do-first, each stored in its own slot. Now there is only in-order-to. + ;; in-order-to used to represent things that modify the filesystem (such as compiling a fasl) + ;; and do-first things that modify the current image (such as loading a fasl). + ;; These are now unified because we now correctly propagate timestamps between dependencies. + ;; Happily, no one seems to have used do-first too much, but the name in-order-to remains. + ;; The names are bad, but they have been the official API since Dan Barlow's ASDF 1.52! + ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively. + ;; Maybe rename the slots in ASDF? But that's not very backward-compatible. + ;; See our ASDF 2 paper for more complete explanations. + (in-order-to :initform nil :initarg :in-order-to + :accessor component-in-order-to) + ;; methods defined using the "inline" style inside a defsystem form: + ;; need to store them somewhere so we can delete them when the system + ;; is re-evaluated + (inline-methods :accessor component-inline-methods :initform nil) ;; OBSOLETE! DELETE THIS IF NO ONE USES. + ;; no direct accessor for pathname, we do this as a method to allow + ;; it to default in funky ways if not supplied + (relative-pathname :initarg :pathname) + ;; the absolute-pathname is computed based on relative-pathname... + (absolute-pathname) + (operation-times :initform (make-hash-table) + :accessor component-operation-times) + (around-compile :initarg :around-compile) + (%encoding :accessor %component-encoding :initform nil :initarg :encoding) + ;; ASDF3: get rid of these "component properties" ? + (properties :accessor component-properties :initarg :properties + :initform nil) + ;; For backward-compatibility, this slot is part of component rather than child-component + (parent :initarg :parent :initform nil :reader component-parent) + (build-operation + :initarg :build-operation :initform nil :reader component-build-operation))) -The traverse operation is wrapped in WITH-COMPILATION-UNIT and error -handling code. If a VERSION argument is supplied, then operate also -ensures that the system found satisfies it using the VERSION-SATISFIES -method. - -Note that dependencies may cause the operation to invoke other -operations on the system or its components: the new operations will be -created with the same initargs as the original one. -")) - (setf (documentation 'oos 'function) - (format nil - "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a" - operate-docstring)) - (setf (documentation 'operate 'function) - operate-docstring)) - -(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-system-operation* system keys) - t) +(defun* component-find-path (component) + (check-type component (or null component)) + (reverse + (loop :for c = component :then (component-parent c) + :while c :collect (component-name c)))) -(defun* load-systems (&rest systems) - (map () 'load-system systems)) +(defmethod print-object ((c component) stream) + (print-unreadable-object (c stream :type t :identity nil) + (format stream "~{~S~^ ~}" (component-find-path c)))) -(defun component-loaded-p (c) - (and (gethash 'load-op (component-operation-times (find-component c nil))) t)) +(defmethod component-system ((component component)) + (if-let (system (component-parent component)) + (component-system system) + component)) -(defun loaded-systems () - (remove-if-not 'component-loaded-p (registered-systems))) -(defun require-system (s &rest keys &key &allow-other-keys) - (apply 'load-system s :force-not (loaded-systems) keys)) +;;;; Component hierarchy within a system +;; The tree typically but not necessarily follows the filesystem hierarchy. -(defun* compile-system (system &rest args &key force verbose version - &allow-other-keys) - "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE -for details." - (declare (ignore force verbose version)) - (apply 'operate 'compile-op system args) - t) +(defclass child-component (component) ()) -(defun* test-system (system &rest args &key force verbose version - &allow-other-keys) - "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for -details." - (declare (ignore force verbose version)) - (apply 'operate 'test-op system args) - t) +(defclass file-component (child-component) + ((type :accessor file-type :initarg :type))) ; no default +(defclass source-file (file-component) + ((type :initform nil))) ;; NB: many systems have come to rely on this default. +(defclass c-source-file (source-file) + ((type :initform "c"))) +(defclass java-source-file (source-file) + ((type :initform "java"))) +(defclass static-file (source-file) + ((type :initform nil))) +(defclass doc-file (static-file) ()) +(defclass html-file (doc-file) + ((type :initform "html"))) -;;;; ------------------------------------------------------------------------- -;;;; Defsystem +(defclass parent-component (component) + ((children + :initform nil + :initarg :components + :reader module-components ; backward-compatibility + :accessor component-children) + (children-by-name + :reader module-components-by-name ; backward-compatibility + :accessor component-children-by-name) + (default-component-class + :initform nil + :initarg :default-component-class + :accessor module-default-component-class))) -(defun* load-pathname () - (resolve-symlinks* (or *load-pathname* *compile-file-pathname*))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun* compute-children-by-name (parent &key only-if-needed-p) + (unless (and only-if-needed-p (slot-boundp parent 'children-by-name)) + (let ((hash (make-hash-table :test 'equal))) + (setf (component-children-by-name parent) hash) + (loop :for c :in (component-children parent) + :for name = (component-name c) + :for previous = (gethash name hash) + :do (when previous (error 'duplicate-names :name name)) + (setf (gethash name hash) c)) + hash)))) + +(when-upgrade (:when (find-class 'module nil)) + (defmethod reinitialize-instance :after ((m module) &rest initargs &key) + (declare (ignorable m initargs)) (values)) + (defmethod update-instance-for-redefined-class :after + ((m module) added deleted plist &key) + (declare (ignorable m added deleted plist)) + (when (and (member 'children added) (member 'components deleted)) + (setf (slot-value m 'children) + ;; old ECLs provide an alist instead of a plist(!) + (if (or #+ecl (consp (first plist))) (or #+ecl (cdr (assoc 'components plist))) + (getf plist 'components))) + (compute-children-by-name m)))) -(defun* determine-system-pathname (pathname) - ;; The defsystem macro calls us to determine - ;; the pathname of a system as follows: - ;; 1. the one supplied, - ;; 2. derived from *load-pathname* via load-pathname - ;; 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 (subpathname directory-pathname pathname :type :directory)) - directory-pathname - (default-directory)))) +(defclass module (child-component parent-component) + ()) -(defun* find-class* (x &optional (errorp t) environment) - (etypecase x - ((or standard-class built-in-class) x) - (symbol (find-class x errorp environment)))) -(defun* class-for-type (parent type) - (or (loop :for symbol :in (list - type - (find-symbol* type *package*) - (find-symbol* type :asdf)) - :for class = (and symbol (find-class symbol nil)) - :when (and class - (#-cormanlisp subtypep #+cormanlisp cl::subclassp - class (find-class 'component))) - :return class) - (and (eq type :file) - (find-class* - (or (loop :for module = parent :then (component-parent module) :while module - :thereis (module-default-component-class module)) - *default-component-class*) nil)) - (sysdef-error "don't recognize component type ~A" type))) +;;;; component pathnames -(defun* maybe-add-tree (tree op1 op2 c) - "Add the node C at /OP1/OP2 in TREE, unless it's there already. -Returns the new tree (which probably shares structure with the old one)" - (let ((first-op-tree (assoc op1 tree))) - (if first-op-tree - (progn - (aif (assoc op2 (cdr first-op-tree)) - (if (find c (cdr it) :test #'equal) - nil - (setf (cdr it) (cons c (cdr it)))) - (setf (cdr first-op-tree) - (acons op2 (list c) (cdr first-op-tree)))) - tree) - (acons op1 (list (list op2 c)) tree)))) - -(defun* union-of-dependencies (&rest deps) - (let ((new-tree nil)) - (dolist (dep deps) - (dolist (op-tree dep) - (dolist (op (cdr op-tree)) - (dolist (c (cdr op)) - (setf new-tree - (maybe-add-tree new-tree (car op-tree) (car op) c)))))) - new-tree)) +(defgeneric* (component-parent-pathname) (component)) +(defmethod component-parent-pathname (component) + (component-pathname (component-parent component))) +(defmethod component-pathname ((component component)) + (if (slot-boundp component 'absolute-pathname) + (slot-value component 'absolute-pathname) + (let ((pathname + (merge-pathnames* + (component-relative-pathname component) + (pathname-directory-pathname (component-parent-pathname component))))) + (unless (or (null pathname) (absolute-pathname-p pathname)) + (error (compatfmt "~@") + pathname (component-find-path component))) + (setf (slot-value component 'absolute-pathname) pathname) + pathname))) -(defvar *serial-depends-on* nil) +(defmethod component-relative-pathname ((component component)) + ;; source-file-type is backward-compatibility with ASDF1; + ;; we ought to be able to extract this from the component alone with COMPONENT-TYPE. + ;; TODO: track who uses it, and have them not use it anymore. + (parse-unix-namestring + (or (and (slot-boundp component 'relative-pathname) + (slot-value component 'relative-pathname)) + (component-name component)) + :want-relative t + :type (source-file-type component (component-system component)) + :defaults (component-parent-pathname component))) -(defun* sysdef-error-component (msg type name value) - (sysdef-error (strcat msg (compatfmt "~&~@")) - type name value)) +(defmethod source-file-type ((component parent-component) system) + (declare (ignorable component system)) + :directory) -(defun* check-component-input (type name weakly-depends-on - depends-on components in-order-to) - "A partial test of the values of a component." - (unless (listp depends-on) - (sysdef-error-component ":depends-on must be a list." - type name depends-on)) - (unless (listp weakly-depends-on) - (sysdef-error-component ":weakly-depends-on must be a list." - type name weakly-depends-on)) - (unless (listp components) - (sysdef-error-component ":components must be NIL or a list of components." - type name components)) - (unless (and (listp in-order-to) (listp (car in-order-to))) - (sysdef-error-component ":in-order-to must be NIL or a list of components." - type name in-order-to))) +(defmethod source-file-type ((component file-component) system) + (declare (ignorable system)) + (file-type component)) -(defun* %remove-component-inline-methods (component) - (dolist (name +asdf-methods+) - (map () - ;; 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)) - (component-inline-methods component))) - ;; clear methods, then add the new ones - (setf (component-inline-methods component) nil)) -(defun* %define-component-inline-methods (ret rest) - (dolist (name +asdf-methods+) - (let ((keyword (intern (symbol-name name) :keyword))) - (loop :for data = rest :then (cddr data) - :for key = (first data) - :for value = (second data) - :while data - :when (eq key keyword) :do - (destructuring-bind (op qual (o c) &body body) value - (pushnew - (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret))) - , at body)) - (component-inline-methods ret))))))) +;;;; General component-property - ASDF3: remove? Define clean subclasses, not messy "properties". -(defun* %refresh-component-inline-methods (component rest) - (%remove-component-inline-methods component) - (%define-component-inline-methods component rest)) +(defmethod component-property ((c component) property) + (cdr (assoc property (slot-value c 'properties) :test #'equal))) -(defun* parse-component-form (parent options) - (destructuring-bind - (type name &rest rest &key - ;; the following list of keywords is reproduced below in the - ;; remove-keys form. important to keep them in sync - components pathname - perform explain output-files operation-done-p - weakly-depends-on depends-on serial in-order-to - do-first - (version nil versionp) - ;; list ends - &allow-other-keys) options - (declare (ignorable perform explain output-files operation-done-p)) - (check-component-input type name weakly-depends-on depends-on components in-order-to) +(defmethod (setf component-property) (new-value (c component) property) + (let ((a (assoc property (slot-value c 'properties) :test #'equal))) + (if a + (setf (cdr a) new-value) + (setf (slot-value c 'properties) + (acons property new-value (slot-value c 'properties))))) + new-value) - (when (and parent - (find-component parent name) - ;; ignore the same object when rereading the defsystem - (not - (typep (find-component parent name) - (class-for-type parent type)))) - (error 'duplicate-names :name name)) - (when versionp - (unless (parse-version version nil) - (warn (compatfmt "~@") - version name parent))) +;;;; Encodings - (let* ((args (list* :name (coerce-name name) - :pathname pathname - :parent parent - (remove-keys - '(components pathname - perform explain output-files operation-done-p - weakly-depends-on depends-on serial in-order-to) - rest))) - (ret (find-component parent name))) - (when weakly-depends-on - (appendf depends-on (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on))) - (when *serial-depends-on* - (push *serial-depends-on* depends-on)) - (if ret ; preserve identity - (apply 'reinitialize-instance ret args) - (setf ret (apply 'make-instance (class-for-type parent type) args))) - (component-pathname ret) ; eagerly compute the absolute pathname - (when (typep ret 'module) - (let ((*serial-depends-on* nil)) - (setf (module-components ret) - (loop - :for c-form :in components - :for c = (parse-component-form ret c-form) - :for name = (component-name c) - :collect c - :when serial :do (setf *serial-depends-on* name)))) - (compute-module-components-by-name ret)) - - (setf (component-load-dependencies ret) depends-on) ;; Used by POIU - - (setf (component-in-order-to ret) - (union-of-dependencies - in-order-to - `((compile-op (compile-op , at depends-on)) - (load-op (load-op , at depends-on))))) - (setf (component-do-first ret) - (union-of-dependencies - do-first - `((compile-op (load-op , at depends-on))))) +(defmethod component-encoding ((c component)) + (or (loop :for x = c :then (component-parent x) + :while x :thereis (%component-encoding x)) + (detect-encoding (component-pathname c)))) - (%refresh-component-inline-methods ret rest) - ret))) +(defmethod component-external-format ((c component)) + (encoding-external-format (component-encoding c))) -(defun* reset-system (system &rest keys &key &allow-other-keys) - (change-class (change-class system 'proto-system) 'system) - (apply 'reinitialize-instance system keys)) -(defun* do-defsystem (name &rest options - &key pathname (class 'system) - defsystem-depends-on &allow-other-keys) - ;; The system must be registered before we parse the body, - ;; otherwise we recur when trying to find an existing system - ;; of the same name to reuse options (e.g. pathname) from. - ;; To avoid infinite recursion in cases where you defsystem a system - ;; that is registered to a different location to find-system, - ;; we also need to remember it in a special variable *systems-being-defined*. - (with-system-definitions () - (let* ((name (coerce-name name)) - (registered (system-registered-p name)) - (registered! (if registered - (rplaca registered (get-universal-time)) - (register-system (make-instance 'system :name name)))) - (system (reset-system (cdr registered!) - :name name :source-file (load-pathname))) - (component-options (remove-keys '(:class) options))) - (setf (gethash name *systems-being-defined*) system) - (apply 'load-systems defsystem-depends-on) - ;; We change-class (when necessary) AFTER we load the defsystem-dep's - ;; since the class might not be defined as part of those. - (let ((class (class-for-type nil class))) - (unless (eq (type-of system) class) - (change-class system class))) - (parse-component-form - nil (list* - :module name - :pathname (determine-system-pathname pathname) - component-options))))) +;;;; around-compile-hook -(defmacro defsystem (name &body options) - `(apply 'do-defsystem ',name ',options)) +(defgeneric* around-compile-hook (component)) +(defmethod around-compile-hook ((c component)) + (cond + ((slot-boundp c 'around-compile) + (slot-value c 'around-compile)) + ((component-parent c) + (around-compile-hook (component-parent c))))) -;;;; --------------------------------------------------------------------------- -;;;; run-shell-command -;;;; -;;;; run-shell-command functions for other lisp implementations will be -;;;; gratefully accepted, if they do the same thing. -;;;; If the docstring is ambiguous, send a bug report. -;;;; -;;;; WARNING! The function below is mostly dysfunctional. -;;;; For instance, it will probably run fine on most implementations on Unix, -;;;; which will hopefully use the shell /bin/sh (which we force in some cases) -;;;; which is hopefully reasonably compatible with a POSIX *or* Bourne shell. -;;;; But behavior on Windows may vary wildly between implementations, -;;;; either relying on your having installed a POSIX sh, or going through -;;;; the CMD.EXE interpreter, for a totally different meaning, depending on -;;;; what is easily expressible in said implementation. -;;;; -;;;; We probably should move this functionality to its own system and deprecate -;;;; use of it from the asdf package. However, this would break unspecified -;;;; existing software, so until a clear alternative exists, we can't deprecate -;;;; it, and even after it's been deprecated, we will support it for a few -;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01 -;;;; -;;;; As a suggested replacement which is portable to all ASDF-supported -;;;; implementations and operating systems except Genera, I recommend -;;;; xcvb-driver's xcvb-driver:run-program/ and its derivatives. -(defun* run-shell-command (control-string &rest args) - "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and -synchronously execute the result using a Bourne-compatible shell, with -output to *VERBOSE-OUT*. Returns the shell's exit code." - (let ((command (apply 'format nil control-string args))) - (asdf-message "; $ ~A~%" command) +;;;; version-satisfies - #+abcl - (ext:run-shell-command command :output *verbose-out*) +(defmethod version-satisfies ((c component) version) + (unless (and version (slot-boundp c 'version)) + (when version + (warn "Requested version ~S but component ~S has no version" version c)) + (return-from version-satisfies t)) + (version-satisfies (component-version c) version)) - #+allegro - ;; will this fail if command has embedded quotes - it seems to work - (multiple-value-bind (stdout stderr exit-code) - (excl.osi:command-output - #-mswindows (vector "/bin/sh" "/bin/sh" "-c" command) - #+mswindows command ; BEWARE! - :input nil :whole nil - #+mswindows :show-window #+mswindows :hide) - (asdf-message "~{~&~a~%~}~%" stderr) - (asdf-message "~{~&~a~%~}~%" stdout) - exit-code) +(defmethod version-satisfies ((cver string) version) + (version-compatible-p cver version)) +;;;; ------------------------------------------------------------------------- +;;;; Systems - #+clisp - ;; CLISP returns NIL for exit status zero. - (if *verbose-out* - (let* ((new-command (format nil "( ~A ) ; r=$? ; echo ; echo ASDF-EXIT-STATUS $r" - command)) - (outstream (ext:run-shell-command new-command :output :stream :wait t))) - (multiple-value-bind (retval out-lines) - (unwind-protect - (parse-clisp-shell-output outstream) - (ignore-errors (close outstream))) - (asdf-message "~{~&~a~%~}~%" out-lines) - retval)) - ;; there will be no output, just grab up the exit status - (or (ext:run-shell-command command :output nil :wait t) 0)) +(asdf/package:define-package :asdf/system + (:recycle :asdf :asdf/system) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/component) + (:export + #:system #:proto-system + #:system-source-file #:system-source-directory #:system-relative-pathname + #:reset-system + #:system-description #:system-long-description + #:system-author #:system-maintainer #:system-licence #:system-license + #:system-defsystem-depends-on + #:component-build-pathname #:build-pathname + #:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system +(in-package :asdf/system) - #+clozure - (nth-value 1 - (ccl:external-process-status - (ccl:run-program - (cond - ((os-unix-p) "/bin/sh") - ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE! - (t (error "Unsupported OS"))) - (if (os-unix-p) (list "-c" command) '()) - :input nil :output *verbose-out* :wait t))) - - #+(or cmu scl) - (ext:process-exit-code - (ext:run-program - "/bin/sh" - (list "-c" command) - :input nil :output *verbose-out*)) - - #+cormanlisp - (win32:system command) - - #+ecl ;; courtesy of Juan Jose Garcia Ripoll - (ext:system command) - - #+gcl - (lisp:system command) - - #+lispworks - (apply 'system:call-system-showing-output command - :show-cmd nil :prefix "" :output-stream *verbose-out* - (when (os-unix-p) '(:shell-type "/bin/sh"))) - - #+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 - #+win32 "sh" #-win32 "/bin/sh" - (list "-c" command) - :input nil :output *verbose-out* - #+win32 '(:search t) #-win32 nil)) - - #+xcl - (ext:run-shell-command command) - - #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl mkcl sbcl scl xcl) - (error "RUN-SHELL-COMMAND not implemented for this Lisp"))) - -#+clisp -(defun* parse-clisp-shell-output (stream) - "Helper function for running shell commands under clisp. Parses a specially- -crafted output string to recover the exit status of the shell command and a -list of lines of output." - (loop :with status-prefix = "ASDF-EXIT-STATUS " - :with prefix-length = (length status-prefix) - :with exit-status = -1 :with lines = () - :for line = (read-line stream nil nil) - :while line :do (push line lines) :finally - (let* ((last (car lines)) - (status (and last (>= (length last) prefix-length) - (string-equal last status-prefix :end1 prefix-length) - (parse-integer last :start prefix-length :junk-allowed t)))) - (when status - (setf exit-status status) - (pop lines) (when (equal "" (car lines)) (pop lines))) - (return (values exit-status (reverse lines)))))) +(defgeneric* (find-system) (system &optional error-p)) +(defgeneric* (system-source-file) (system) + (:documentation "Return the source file in which system is defined.")) +(defgeneric* builtin-system-p (system)) +(defgeneric* component-build-pathname (component)) -;;;; --------------------------------------------------------------------------- -;;;; system-relative-pathname +;;;; The system class -(defun* system-definition-pathname (x) - ;; As of 2.014.8, we mean to make this function obsolete, - ;; but that won't happen until all clients have been updated. - ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead" - "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete. -It used to expose ASDF internals with subtle differences with respect to -user expectations, that have been refactored away since. -We recommend you use ASDF:SYSTEM-SOURCE-FILE instead -for a mostly compatible replacement that we're supporting, -or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME -if that's whay you mean." ;;) - (system-source-file x)) +(defclass proto-system () ; slots to keep when resetting a system + ;; To preserve identity for all objects, we'd need keep the components slots + ;; but also to modify parse-component-form to reset the recycled objects. + ((name) (source-file) #|(children) (children-by-names)|#)) + +(defclass system (module proto-system) + ;; Backward-compatibility: inherit from module. ASDF3: only inherit from parent-component. + (;; {,long-}description is now inherited from component, but we add the legacy accessors + (description :accessor system-description) + (long-description :accessor system-long-description) + (author :accessor system-author :initarg :author) + (maintainer :accessor system-maintainer :initarg :maintainer) + (licence :accessor system-licence :initarg :licence + :accessor system-license :initarg :license) + (build-pathname + :initform nil :initarg :build-pathname :accessor component-build-pathname) + (source-file :initform nil :initarg :source-file :accessor system-source-file) + (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) + +(defun* reset-system (system &rest keys &key &allow-other-keys) + (change-class (change-class system 'proto-system) 'system) + (apply 'reinitialize-instance system keys)) + + +;;;; Pathnames -(defmethod system-source-file ((system system)) - ;; might be missing when upgrading from ASDF 1 and u-i-f-r-c failed - (unless (slot-boundp system 'source-file) - (%set-system-source-file - (probe-asd (component-name system) (component-pathname system)) system)) - (slot-value system 'source-file)) (defmethod system-source-file ((system-name string)) (system-source-file (find-system system-name))) (defmethod system-source-file ((system-name symbol)) (system-source-file (find-system system-name))) (defun* system-source-directory (system-designator) - "Return a pathname object corresponding to the -directory in which the system specification (.asd file) is -located." + "Return a pathname object corresponding to the directory +in which the system specification (.asd file) is located." (pathname-directory-pathname (system-source-file system-designator))) -(defun* relativize-directory (directory) - (cond - ((stringp directory) - (list :relative directory)) - ((eq (car directory) :absolute) - (cons :relative (cdr directory))) - (t - directory))) - -(defun* relativize-pathname-directory (pathspec) - (let ((p (pathname pathspec))) - (make-pathname - :directory (relativize-directory (pathname-directory p)) - :defaults p))) - -(defun* system-relative-pathname (system name &key type) +(defun* (system-relative-pathname) (system name &key type) (subpathname (system-source-directory system) name :type type)) +(defmethod component-pathname ((system system)) + (or (call-next-method) + (system-source-directory system))) + +(defmethod component-relative-pathname ((system system)) + (parse-unix-namestring + (and (slot-boundp system 'relative-pathname) + (slot-value system 'relative-pathname)) + :want-relative t + :type :directory + :ensure-absolute t + :defaults (system-source-directory system))) -;;; --------------------------------------------------------------------------- -;;; implementation-identifier -;;; -;;; produce a string to identify current implementation. -;;; Initially stolen from SLIME's SWANK, rewritten since. -;;; We're back to runtime checking, for the sake of e.g. ABCL. - -(defun* first-feature (features) - (dolist (x features) - (multiple-value-bind (val feature) - (if (consp x) (values (first x) (cons :or (rest x))) (values x x)) - (when (featurep feature) (return val))))) +(defmethod component-parent-pathname ((system system)) + (system-source-directory system)) -(defun implementation-type () - (first-feature - '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu - :ecl :gcl (:lw :lispworks) :mcl :mkcl :sbcl :scl :symbolics :xcl))) +(defmethod component-build-pathname ((c component)) + (declare (ignorable c)) + nil) +;;;; ------------------------------------------------------------------------- +;;;; Finding systems -(defun operating-system () - (first-feature - '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! - (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd - (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd - (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix - :genera))) +(asdf/package:define-package :asdf/find-system + (:recycle :asdf/find-system :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/component :asdf/system) + (:export + #:remove-entry-from-registry #:coerce-entry-to-directory + #:coerce-name #:primary-system-name + #:find-system #:locate-system #:load-sysdef #:with-system-definitions + #:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems + #:system-definition-error #:missing-component #:missing-requires #:missing-parent + #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error + #:load-system-definition-error #:error-name #:error-pathname #:error-condition + #:*system-definition-search-functions* #:search-for-system-definition + #:*central-registry* #:probe-asd #:sysdef-central-registry-search + #:make-temporary-package #:find-system-if-being-defined #:*systems-being-defined* + #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed + #:system-find-preloaded-system #:register-preloaded-system #:*preloaded-systems* + #:make-defined-systems-table #:*defined-systems* + ;; defined in source-registry, but specially mentioned here: + #:initialize-source-registry #:sysdef-source-registry-search)) +(in-package :asdf/find-system) -(defun architecture () - (first-feature - '((:x64 :amd64 :x86-64 :x86_64 :x8664-target (:and :word-size=64 :pc386)) - (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target) - (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc) - :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc) - :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach - ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI, - ;; we may have to segregate the code still by architecture. - (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))) +(declaim (ftype (function (&optional t) t) initialize-source-registry)) ; forward reference -#+clozure -(defun* ccl-fasl-version () - ;; the fasl version is target-dependent from CCL 1.8 on. - (or (let ((s 'ccl::target-fasl-version)) - (and (fboundp s) (funcall s))) - (and (boundp 'ccl::fasl-version) - (symbol-value 'ccl::fasl-version)) - (error "Can't determine fasl version."))) +(define-condition system-definition-error (error) () + ;; [this use of :report should be redundant, but unfortunately it's not. + ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function + ;; over print-object; this is always conditions::%print-condition for + ;; condition objects, which in turn does inheritance of :report options at + ;; run-time. fortunately, inheritance means we only need this kludge here in + ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] + #+cmu (:report print-object)) -(defun lisp-version-string () - (let ((s (lisp-implementation-version))) - (car ; as opposed to OR, this idiom prevents some unreachable code warning - (list - #+allegro - (format nil "~A~@[~A~]~@[~A~]~@[~A~]" - excl::*common-lisp-version-number* - ;; 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")) - (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.) - #+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) - #+scl (format nil "~A~A" s - ;; ANSI upper case vs lower case. - (ecase ext:*case-mode* (:upper "") (:lower "l"))) - #+ecl (format nil "~A~@[-~A~]" s - (let ((vcs-id (ext:lisp-implementation-vcs-id))) - (subseq vcs-id 0 (min (length vcs-id) 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)) - #+mcl (subseq s 8) ; strip the leading "Version " - s)))) +(define-condition missing-component (system-definition-error) + ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) + (parent :initform nil :reader missing-parent :initarg :parent))) -(defun* implementation-identifier () - (substitute-if - #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\"")) - (format nil "~(~a~@{~@[-~a~]~}~)" - (or (implementation-type) (lisp-implementation-type)) - (or (lisp-version-string) (lisp-implementation-version)) - (or (operating-system) (software-type)) - (or (architecture) (machine-type))))) +(define-condition formatted-system-definition-error (system-definition-error) + ((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))))) -(defun* hostname () - ;; Note: untested on RMCL - #+(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 " ")) - #+gcl (system:gethostname)) +(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 (compatfmt "~@") + (error-name c) (error-pathname c) (error-condition c))))) +(defun* sysdef-error (format &rest arguments) + (error 'formatted-system-definition-error :format-control + format :format-arguments arguments)) -;;; --------------------------------------------------------------------------- -;;; Generic support for configuration files +(defun* make-defined-systems-table () + (make-hash-table :test 'equal)) + +(defvar *defined-systems* (make-defined-systems-table) + "This is a hash table whose keys are strings, being the +names of the systems, and whose values are pairs, the first +element of which is a universal-time indicating when the +system definition was last updated, and the second element +of which is a system object.") + +(defun* coerce-name (name) + (typecase name + (component (component-name name)) + (symbol (string-downcase (symbol-name name))) + (string name) + (t (sysdef-error (compatfmt "~@") name)))) + +(defun* primary-system-name (name) + ;; When a system name has slashes, the file with defsystem is named by + ;; the first of the slash-separated components. + (first (split-string (coerce-name name) :separator "/"))) + +(defun* system-registered-p (name) + (gethash (coerce-name name) *defined-systems*)) + +(defun* registered-systems () + (loop :for registered :being :the :hash-values :of *defined-systems* + :collect (coerce-name (cdr registered)))) + +(defun* register-system (system) + (check-type system system) + (let ((name (component-name system))) + (check-type name string) + (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) + (unless (eq system (cdr (gethash name *defined-systems*))) + (setf (gethash name *defined-systems*) + (cons (if-let (file (ignore-errors (system-source-file system))) + (safe-file-write-date file)) + system))))) + +(defun* clear-system (name) + "Clear the entry for a system in the database of systems previously loaded. +Note that this does NOT in any way cause the code of the system to be unloaded." + ;; There is no "unload" operation in Common Lisp, and + ;; a general such operation cannot be portably written, + ;; considering how much CL relies on side-effects to global data structures. + (remhash (coerce-name name) *defined-systems*)) + +(defun* map-systems (fn) + "Apply FN to each defined system. + +FN should be a function of one argument. It will be +called with an object of type asdf:system." + (loop :for registered :being :the :hash-values :of *defined-systems* + :do (funcall fn (cdr registered)))) + +;;; for the sake of keeping things reasonably neat, we adopt a +;;; convention that functions in this list are prefixed SYSDEF- + +(defvar *system-definition-search-functions* '()) + +(defun cleanup-system-definition-search-functions () + (setf *system-definition-search-functions* + (append + ;; Remove known-incompatible sysdef functions from old versions of asdf. + (remove-if #'(lambda (x) (member x '(contrib-sysdef-search sysdef-find-asdf))) + *system-definition-search-functions*) + ;; Tuck our defaults at the end of the list if they were absent. + ;; This is imperfect, in case they were removed on purpose, + ;; but then it will be the responsibility of whoever does that + ;; to upgrade asdf before he does such a thing rather than after. + (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) + '(sysdef-central-registry-search + sysdef-source-registry-search + sysdef-find-preloaded-systems))))) +(cleanup-system-definition-search-functions) + +(defun* search-for-system-definition (system) + (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name))) + (cons 'find-system-if-being-defined + *system-definition-search-functions*))) + +(defvar *central-registry* nil +"A list of 'system directory designators' ASDF uses to find systems. + +A 'system directory designator' is a pathname or an expression +which evaluates to a pathname. For example: + + (setf asdf:*central-registry* + (list '*default-pathname-defaults* + #p\"/home/me/cl/systems/\" + #p\"/usr/share/common-lisp/systems/\")) + +This is for backward compatibility. +Going forward, we recommend new users should be using the source-registry. +") + +(defun* probe-asd (name defaults &key truename) + (block nil + (when (directory-pathname-p defaults) + (let* ((file (probe-file* + (absolutize-pathnames + (list (make-pathname :name name :type "asd") + defaults *default-pathname-defaults* (getcwd)) + :resolve-symlinks truename) + :truename truename))) + (when file + (return file))) + #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) + (when (os-windows-p) + (let ((shortcut + (make-pathname + :defaults defaults :case :local + :name (strcat name ".asd") + :type "lnk"))) + (when (probe-file* shortcut) + (let ((target (parse-windows-shortcut shortcut))) + (when target + (return (pathname target)))))))))) + +(defun* sysdef-central-registry-search (system) + (let ((name (primary-system-name system)) + (to-remove nil) + (to-replace nil)) + (block nil + (unwind-protect + (dolist (dir *central-registry*) + (let ((defaults (eval dir)) + directorized) + (when defaults + (cond ((directory-pathname-p defaults) + (let* ((file (probe-asd name defaults :truename *resolve-symlinks*))) + (when file + (return file)))) + (t + (restart-case + (let* ((*print-circle* nil) + (message + (format nil + (compatfmt "~@") + system dir defaults))) + (error message)) + (remove-entry-from-registry () + :report "Remove entry from *central-registry* and continue" + (push dir to-remove)) + (coerce-entry-to-directory () + :test (lambda (c) (declare (ignore c)) + (and (not (directory-pathname-p defaults)) + (directory-pathname-p + (setf directorized + (ensure-directory-pathname defaults))))) + :report (lambda (s) + (format s (compatfmt "~@") + directorized dir)) + (push (cons dir directorized) to-replace)))))))) + ;; cleanup + (dolist (dir to-remove) + (setf *central-registry* (remove dir *central-registry*))) + (dolist (pair to-replace) + (let* ((current (car pair)) + (new (cdr pair)) + (position (position current *central-registry*))) + (setf *central-registry* + (append (subseq *central-registry* 0 position) + (list new) + (subseq *central-registry* (1+ position)))))))))) + +(defun* make-temporary-package () + (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf/interface))) + +(defmethod find-system ((name null) &optional (error-p t)) + (declare (ignorable name)) + (when error-p + (sysdef-error (compatfmt "~@")))) + +(defmethod find-system (name &optional (error-p t)) + (find-system (coerce-name name) error-p)) + +(defvar *systems-being-defined* nil + "A hash-table of systems currently being defined keyed by name, or NIL") + +(defun* find-system-if-being-defined (name) + (when *systems-being-defined* + (gethash (coerce-name name) *systems-being-defined*))) + +(defun* call-with-system-definitions (thunk) + (if *systems-being-defined* + (funcall thunk) + (let ((*systems-being-defined* (make-hash-table :test 'equal))) + (funcall thunk)))) + +(defmacro with-system-definitions ((&optional) &body body) + `(call-with-system-definitions #'(lambda () , at body))) + +(defun* load-sysdef (name pathname) + ;; Tries to load system definition with canonical NAME from PATHNAME. + (with-system-definitions () + (let ((package (make-temporary-package))) ;; ASDF3: get rid of that. + (unwind-protect + (handler-bind + ((error #'(lambda (condition) + (error 'load-system-definition-error + :name name :pathname pathname + :condition condition)))) + (let ((*package* package) + (*default-pathname-defaults* + ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. + (pathname-directory-pathname (translate-logical-pathname pathname))) + (external-format (encoding-external-format (detect-encoding pathname)))) + (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") + pathname package) + (with-muffled-loader-conditions () + (load* pathname :external-format external-format)))) + (delete-package package))))) + +(defun* locate-system (name) + "Given a system NAME designator, try to locate where to load the system from. +Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME +FOUNDP is true when a system was found, +either a new unregistered one or a previously registered one. +FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is +PATHNAME when not null is a path from where to load the system, +either associated with FOUND-SYSTEM, or with the PREVIOUS system. +PREVIOUS when not null is a previously loaded SYSTEM object of same name. +PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." + (let* ((name (coerce-name name)) + (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk + (previous (cdr in-memory)) + (previous (and (typep previous 'system) previous)) + (previous-time (car in-memory)) + (found (search-for-system-definition name)) + (found-system (and (typep found 'system) found)) + (pathname (or (and (typep found '(or pathname string)) (pathname found)) + (and found-system (system-source-file found-system)) + (and previous (system-source-file previous)))) + (pathname (ensure-pathname (resolve-symlinks* pathname) :want-absolute t)) + (foundp (and (or found-system pathname previous) t))) + (check-type found (or null pathname system)) + (values foundp found-system pathname previous previous-time))) + +(defmethod find-system ((name string) &optional (error-p t)) + (with-system-definitions () + (loop + (restart-case + (multiple-value-bind (foundp found-system pathname previous previous-time) + (locate-system name) + (assert (eq foundp (and (or found-system pathname previous) t))) + (let ((previous-pathname (and previous (system-source-file previous))) + (system (or previous found-system))) + (when (and found-system (not previous)) + (register-system found-system)) + (when (and system pathname) + (setf (system-source-file system) pathname)) + (when (and pathname + (not (and previous + (or (pathname-equal pathname previous-pathname) + (and pathname previous-pathname + (pathname-equal + (translate-logical-pathname pathname) + (translate-logical-pathname previous-pathname)))) + (stamp<= (safe-file-write-date pathname) previous-time)))) + ;; only load when it's a pathname that is different or has newer content + (load-sysdef name pathname))) + (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed + (return + (cond + (in-memory + (when pathname + (setf (car in-memory) (safe-file-write-date pathname))) + (cdr in-memory)) + (error-p + (error 'missing-component :requires name)))))) + (reinitialize-source-registry-and-retry () + :report (lambda (s) + (format s (compatfmt "~@") name)) + (initialize-source-registry)))))) + +(defvar *preloaded-systems* (make-hash-table :test 'equal)) + +(defun* sysdef-find-preloaded-systems (requested) + (let ((name (coerce-name requested))) + (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*) + (when foundp + (apply 'make-instance 'system :name name :source-file (getf keys :source-file) keys))))) + +(defun register-preloaded-system (system-name &rest keys) + (setf (gethash (coerce-name system-name) *preloaded-systems*) keys)) + +(register-preloaded-system "asdf") +(register-preloaded-system "asdf-driver") + +;;;; Beware of builtin systems +(defmethod builtin-system-p ((s system)) + (or + ;; For most purposes, asdf itself specially counts as builtin. + ;; if you want to link it or do something forbidden to builtins, + ;; specify separate dependencies on asdf-driver and asdf-defsystem. + (equal "asdf" (coerce-name s)) + ;; Other builtin systems are those under the implementation directory + (let* ((system (find-system s nil)) + (sysdir (and system (component-pathname system))) + (truesysdir (truename* sysdir)) + (impdir (lisp-implementation-directory)) + (trueimpdir (truename* impdir))) + (and sysdir impdir + (or (subpathp sysdir impdir) + (subpathp truesysdir trueimpdir)))))) +;;;; ------------------------------------------------------------------------- +;;;; Finding components + +(asdf/package:define-package :asdf/find-component + (:recycle :asdf/find-component :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/component :asdf/system :asdf/find-system) + (:export + #:find-component + #:resolve-dependency-name #:resolve-dependency-spec + #:resolve-dependency-combination + ;; Conditions + #:missing-component #:missing-component-of-version #:retry + #:missing-dependency #:missing-dependency-of-version + #:missing-requires #:missing-parent + #:missing-required-by #:missing-version)) +(in-package :asdf/find-component) + +;;;; Missing component conditions + +(define-condition missing-component-of-version (missing-component) + ((version :initform nil :reader missing-version :initarg :version))) + +(define-condition missing-dependency (missing-component) + ((required-by :initarg :required-by :reader missing-required-by))) + +(defmethod print-object ((c missing-dependency) s) + (format s (compatfmt "~@<~A, required by ~A~@:>") + (call-next-method c nil) (missing-required-by c))) + +(define-condition missing-dependency-of-version (missing-dependency + missing-component-of-version) + ()) + +(defmethod print-object ((c missing-component) s) + (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 (compatfmt "~@") + (missing-requires c) + (missing-version c) + (when (missing-parent c) + (coerce-name (missing-parent c))))) + + +;;;; Finding components + +(defgeneric* (find-component) (base path) + (:documentation "Find a component by resolving the PATH starting from BASE parent")) +(defgeneric* resolve-dependency-combination (component combinator arguments)) + +(defmethod find-component ((base string) path) + (let ((s (find-system base nil))) + (and s (find-component s path)))) + +(defmethod find-component ((base symbol) path) + (cond + (base (find-component (coerce-name base) path)) + (path (find-component path nil)) + (t nil))) + +(defmethod find-component ((base cons) path) + (find-component (car base) (cons (cdr base) path))) + +(defmethod find-component ((parent parent-component) (name string)) + (compute-children-by-name parent :only-if-needed-p t) ;; SBCL may miss the u-i-f-r-c method!!! + (values (gethash name (component-children-by-name parent)))) + +(defmethod find-component (base (name symbol)) + (if name + (find-component base (coerce-name name)) + base)) + +(defmethod find-component ((c component) (name cons)) + (find-component (find-component c (car name)) (cdr name))) + +(defmethod find-component (base (actual component)) + (declare (ignorable base)) + actual) + +(defun* resolve-dependency-name (component name &optional version) + (loop + (restart-case + (return + (let ((comp (find-component (component-parent component) name))) + (unless comp + (error 'missing-dependency + :required-by component + :requires name)) + (when version + (unless (version-satisfies comp version) + (error 'missing-dependency-of-version + :required-by component + :version version + :requires name))) + comp)) + (retry () + :report (lambda (s) + (format s (compatfmt "~@") name)) + :test + (lambda (c) + (or (null c) + (and (typep c 'missing-dependency) + (eq (missing-required-by c) component) + (equal (missing-requires c) name)))))))) + +(defun* resolve-dependency-spec (component dep-spec) + (let ((component (find-component () component))) + (if (atom dep-spec) + (resolve-dependency-name component dep-spec) + (resolve-dependency-combination component (car dep-spec) (cdr dep-spec))))) + +(defmethod resolve-dependency-combination (component combinator arguments) + (error (compatfmt "~@") + (cons combinator arguments) component)) + +(defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments) + (declare (ignorable combinator)) + (when (featurep (first arguments)) + (resolve-dependency-spec component (second arguments)))) + +(defmethod resolve-dependency-combination (component (combinator (eql :version)) arguments) + (declare (ignorable combinator)) ;; See https://bugs.launchpad.net/asdf/+bug/527788 + (resolve-dependency-name component (first arguments) (second arguments))) + +;;;; ------------------------------------------------------------------------- +;;;; Operations + +(asdf/package:define-package :asdf/operation + (:recycle :asdf/operation :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade) + (:export + #:operation + #:operation-original-initargs ;; backward-compatibility only. DO NOT USE. + #:build-op ;; THE generic operation + #:*operations* + #:make-operation + #:find-operation)) +(in-package :asdf/operation) + +;;; Operation Classes + +(when-upgrade (:when (find-class 'operation nil)) + (defmethod shared-initialize :after ((o operation) slot-names &rest initargs &key) + (declare (ignorable o slot-names initargs)) (values))) + +(defclass operation () + ((original-initargs ;; for backward-compat -- used by GBBopen and swank (via operation-forced) + :initform nil :initarg :original-initargs :accessor operation-original-initargs))) + +(defmethod initialize-instance :after ((o operation) &rest initargs + &key force force-not system verbose &allow-other-keys) + (declare (ignorable force force-not system verbose)) + (unless (slot-boundp o 'original-initargs) + (setf (operation-original-initargs o) initargs))) + +(defmethod print-object ((o operation) stream) + (print-unreadable-object (o stream :type t :identity nil) + (ignore-errors + (format stream "~{~S~^ ~}" (operation-original-initargs o))))) + +;;; make-operation, find-operation + +(defparameter *operations* (make-hash-table :test 'equal)) +(defun* make-operation (operation-class &rest initargs) + (let ((key (cons operation-class initargs))) + (multiple-value-bind (operation foundp) (gethash key *operations*) + (if foundp operation + (setf (gethash key *operations*) + (apply 'make-instance operation-class initargs)))))) + +(defgeneric* find-operation (context spec) + (:documentation "Find an operation by resolving the SPEC in the CONTEXT")) +(defmethod find-operation (context (spec operation)) + (declare (ignorable context)) + spec) +(defmethod find-operation (context (spec symbol)) + (apply 'make-operation spec (operation-original-initargs context))) +(defmethod operation-original-initargs ((context symbol)) + (declare (ignorable context)) + nil) + +(defclass build-op (operation) ()) + +;;;; ------------------------------------------------------------------------- +;;;; Actions + +(asdf/package:define-package :asdf/action + (:nicknames :asdf-action) + (:recycle :asdf/action :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation) + (:intern #:stamp #:done-p) + (:export + #:action #:define-convenience-action-methods + #:explain #:operation-description + #:downward-operation #:upward-operation #:sibling-operation + #:component-depends-on #:component-self-dependencies + #:input-files #:output-files #:output-file #:operation-done-p + #:action-status #:action-stamp #:action-done-p + #:component-operation-time #:mark-operation-done #:compute-action-stamp + #:perform #:perform-with-restarts #:retry #:accept #:feature + #:traverse-actions #:traverse-sub-actions #:required-components ;; in plan + #:action-path #:find-action + )) +(in-package :asdf/action) + +(deftype action () '(cons operation component)) ;; a step to be performed while building the system + +(defgeneric* traverse-actions (actions &key &allow-other-keys)) +(defgeneric* traverse-sub-actions (operation component &key &allow-other-keys)) +(defgeneric* required-components (component &key &allow-other-keys)) + +;;;; Reified representation for storage or debugging. Note: dropping original-initags +(defun action-path (action) + (destructuring-bind (o . c) action (cons (type-of o) (component-find-path c)))) +(defun find-action (path) + (destructuring-bind (o . c) path (cons (make-operation o) (find-component () c)))) + + +;;;; Convenience methods +(defmacro define-convenience-action-methods + (function (operation component &optional keyp) + &key if-no-operation if-no-component operation-initargs) + (let* ((rest (gensym "REST")) + (found (gensym "FOUND")) + (more-args (when keyp `(&rest ,rest &key &allow-other-keys)))) + (flet ((next-method (o c) + (if keyp + `(apply ',function ,o ,c ,rest) + `(,function ,o ,c)))) + `(progn + (defmethod ,function ((,operation symbol) ,component , at more-args) + (if ,operation + ,(next-method + (if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck. + `(apply 'make-operation ,operation :original-initargs ,rest ,rest) + `(make-operation ,operation)) + `(find-component () ,component)) + ,if-no-operation)) + (defmethod ,function ((,operation operation) ,component , at more-args) + (if (typep ,component 'component) + (error "No defined method for ~S on ~S" ',function ,component) + (let ((,found (find-component () ,component))) + (if ,found + ,(next-method operation found) + ,if-no-component)))))))) + + +;;;; self-description + +(defgeneric* operation-description (operation component) ;; ASDF3: rename to action-description + (:documentation "returns a phrase that describes performing this operation +on this component, e.g. \"loading /a/b/c\". +You can put together sentences using this phrase.")) +(defmethod operation-description (operation component) + (format nil (compatfmt "~@<~A on ~A~@:>") + (type-of operation) component)) +(defgeneric* (explain) (operation component)) +(defmethod explain ((o operation) (c component)) + (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (operation-description o c))) +(define-convenience-action-methods explain (operation component)) + +(defun* format-action (stream action &optional colon-p at-sign-p) + (assert (null colon-p)) (assert (null at-sign-p)) + (destructuring-bind (operation . component) action + (princ (operation-description operation component) stream))) + + +;;;; Dependencies + +(defgeneric* component-depends-on (operation component) ;; ASDF3: rename to component-dependencies + (:documentation + "Returns a list of dependencies needed by the component to perform + the operation. A dependency has one of the following forms: + + ( *), where is a class + designator and each is a component + designator, which means that the component depends on + having been performed on each ; or + + (FEATURE ), which means that the component depends + on 's presence in *FEATURES*. + + Methods specialized on subclasses of existing component types + should usually append the results of CALL-NEXT-METHOD to the + list.")) +(defgeneric* component-self-dependencies (operation component)) +(define-convenience-action-methods component-depends-on (operation component)) +(define-convenience-action-methods component-self-dependencies (operation component)) + +(defmethod component-depends-on ((o operation) (c component)) + (cdr (assoc (type-of o) (component-in-order-to c)))) ; User-specified in-order dependencies + +(defmethod component-self-dependencies ((o operation) (c component)) + ;; NB: result in the same format as component-depends-on + (loop* :for (o-spec . c-spec) :in (component-depends-on o c) + :unless (eq o-spec 'feature) ;; avoid the FEATURE "feature" + :when (find c c-spec :key #'(lambda (dep) (resolve-dependency-spec c dep))) + :collect (list o-spec c))) + +;;;; upward-operation, downward-operation +;; These together handle actions that propagate along the component hierarchy. +;; Downward operations like load-op or compile-op propagate down the hierarchy: +;; operation on a parent depends-on operation on its children. +;; By default, an operation propagates itself, but it may propagate another one instead. +(defclass downward-operation (operation) + ((downward-operation + :initform nil :initarg :downward-operation :reader downward-operation))) +(defmethod component-depends-on ((o downward-operation) (c parent-component)) + `((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next-method))) +;; Upward operations like prepare-op propagate up the component hierarchy: +;; operation on a child depends-on operation on its parent. +;; By default, an operation propagates itself, but it may propagate another one instead. +(defclass upward-operation (operation) + ((upward-operation + :initform nil :initarg :downward-operation :reader upward-operation))) +;; For backward-compatibility reasons, a system inherits from module and is a child-component +;; so we must guard against this case. ASDF3: remove that. +(defmethod component-depends-on ((o upward-operation) (c child-component)) + `(,@(if-let (p (component-parent c)) + `((,(or (upward-operation o) o) ,p))) ,@(call-next-method))) +;; Sibling operations propagate to siblings in the component hierarchy: +;; operation on a child depends-on operation on its parent. +;; By default, an operation propagates itself, but it may propagate another one instead. +(defclass sibling-operation (operation) + ((sibling-operation + :initform nil :initarg :sibling-operation :reader sibling-operation))) +(defmethod component-depends-on ((o sibling-operation) (c component)) + `((,(or (sibling-operation o) o) + ,@(loop :for dep :in (component-sibling-dependencies c) + :collect (resolve-dependency-spec c dep))) + ,@(call-next-method))) + + +;;;; Inputs, Outputs, and invisible dependencies +(defgeneric* (output-files) (operation component)) +(defgeneric* (input-files) (operation component)) +(defgeneric* (operation-done-p) (operation component) + (:documentation "Returns a boolean, which is NIL if the action is forced to be performed again")) +(define-convenience-action-methods output-files (operation component)) +(define-convenience-action-methods input-files (operation component)) +(define-convenience-action-methods operation-done-p (operation component)) + +(defmethod operation-done-p ((o operation) (c component)) + (declare (ignorable o c)) + t) + +(defmethod output-files :around (operation component) + "Translate output files, unless asked not to" + operation component ;; hush genera, not convinced by declare ignorable(!) + (values + (multiple-value-bind (pathnames fixedp) (call-next-method) + ;; 1- Make sure we have absolute pathnames + (let* ((directory (pathname-directory-pathname + (component-pathname (find-component () component)))) + (absolute-pathnames + (loop + :for pathname :in pathnames + :collect (ensure-pathname-absolute pathname directory)))) + ;; 2- Translate those pathnames as required + (if fixedp + absolute-pathnames + (mapcar *output-translation-function* absolute-pathnames)))) + t)) +(defmethod output-files ((o operation) (c component)) + (declare (ignorable o c)) + nil) +(defun* output-file (operation component) + "The unique output file of performing OPERATION on COMPONENT" + (let ((files (output-files operation component))) + (assert (length=n-p files 1)) + (first files))) + +(defmethod input-files ((o operation) (c parent-component)) + (declare (ignorable o c)) + nil) + +(defmethod input-files ((o operation) (c component)) + (or (loop* :for (dep-o) :in (component-self-dependencies o c) + :append (or (output-files dep-o c) (input-files dep-o c))) + ;; no non-trivial previous operations needed? + ;; I guess we work with the original source file, then + (if-let ((pathname (component-pathname c))) + (and (file-pathname-p pathname) (list pathname))))) + + +;;;; Done performing + +(defgeneric* component-operation-time (operation component)) ;; ASDF3: hide it behind plan-action-stamp +(define-convenience-action-methods component-operation-time (operation component)) + + +(defgeneric* mark-operation-done (operation component)) ;; ASDF3: hide it behind (setf plan-action-stamp) +(defgeneric* compute-action-stamp (plan operation component &key just-done) + (:documentation "Has this action been successfully done already, +and at what known timestamp has it been done at or will it be done at? +Takes two keywords JUST-DONE and PLAN: +JUST-DONE is a boolean that is true if the action was just successfully performed, +at which point we want compute the actual stamp and warn if files are missing; +otherwise we are making plans, anticipating the effects of the action. +PLAN is a plan object modelling future effects of actions, +or NIL to denote what actually happened. +Returns two values: +* a STAMP saying when it was done or will be done, + or T if the action has involves files that need to be recomputed. +* a boolean DONE-P that indicates whether the action has actually been done, + and both its output-files and its in-image side-effects are up to date.")) + +(defclass action-status () + ((stamp + :initarg :stamp :reader action-stamp + :documentation "STAMP associated with the ACTION if it has been completed already +in some previous image, or T if it needs to be done.") + (done-p + :initarg :done-p :reader action-done-p + :documentation "a boolean, true iff the action was already done (before any planned action).")) + (:documentation "Status of an action")) + +(defmethod print-object ((status action-status) stream) + (print-unreadable-object (status stream :type t) + (with-slots (stamp done-p) status + (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p)))) + +(defmethod component-operation-time ((o operation) (c component)) + (gethash (type-of o) (component-operation-times c))) + +(defmethod mark-operation-done ((o operation) (c component)) + (setf (gethash (type-of o) (component-operation-times c)) + (compute-action-stamp nil o c :just-done t))) + + +;;;; Perform + +(defgeneric* (perform-with-restarts) (operation component)) +(defgeneric* (perform) (operation component)) +(define-convenience-action-methods perform (operation component)) + +(defmethod perform :before ((o operation) (c component)) + (ensure-all-directories-exist (output-files o c))) +(defmethod perform :after ((o operation) (c component)) + (mark-operation-done o c)) +(defmethod perform ((o operation) (c parent-component)) + (declare (ignorable o c)) + nil) +(defmethod perform ((o operation) (c source-file)) + (sysdef-error + (compatfmt "~@") + (class-of o) (class-of c))) + +(defmethod perform-with-restarts (operation component) + ;; TOO verbose, especially as the default. Add your own :before method + ;; to perform-with-restart or perform if you want that: + #|(when *asdf-verbose* (explain operation component))|# + (perform operation component)) +(defmethod perform-with-restarts :around (operation component) + (loop + (restart-case + (return (call-next-method)) + (retry () + :report + (lambda (s) + (format s (compatfmt "~@") + (operation-description operation component)))) + (accept () + :report + (lambda (s) + (format s (compatfmt "~@") + (operation-description operation component))) + (mark-operation-done operation component) + (return))))) + +;;; Generic build operation +(defmethod component-depends-on ((o build-op) (c component)) + `((,(or (component-build-operation c) 'load-op) ,c))) + +;;;; ------------------------------------------------------------------------- +;;;; Actions to build Common Lisp software + +(asdf/package:define-package :asdf/lisp-action + (:recycle :asdf/lisp-action :asdf) + (:intern #:proclamations #:flags) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/component :asdf/system :asdf/find-component :asdf/operation :asdf/action) + (:export + #:try-recompiling + #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp + #:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proclamations + #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op + #:call-with-around-compile-hook + #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source)) +(in-package :asdf/lisp-action) + + +;;;; Component classes +(defclass cl-source-file (source-file) + ((type :initform "lisp"))) +(defclass cl-source-file.cl (cl-source-file) + ((type :initform "cl"))) +(defclass cl-source-file.lsp (cl-source-file) + ((type :initform "lsp"))) + + +;;;; Operation classes +(defclass basic-load-op (operation) ()) +(defclass basic-compile-op (operation) + ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) + (flags :initarg :flags :accessor compile-op-flags + :initform nil))) + +;;; Our default operations: loading into the current lisp image +(defclass load-op (basic-load-op downward-operation sibling-operation) ()) +(defclass prepare-op (upward-operation sibling-operation) + ((sibling-operation :initform 'load-op :allocation :class))) +(defclass compile-op (basic-compile-op downward-operation) + ((downward-operation :initform 'load-op :allocation :class))) + +(defclass load-source-op (basic-load-op downward-operation) ()) +(defclass prepare-source-op (upward-operation sibling-operation) + ((sibling-operation :initform 'load-source-op :allocation :class))) + +(defclass test-op (operation) ()) + + +;;;; prepare-op, compile-op and load-op + +;;; prepare-op +(defmethod operation-description ((o prepare-op) (c component)) + (declare (ignorable o)) + (format nil (compatfmt "~@") c)) +(defmethod perform ((o prepare-op) (c component)) + (declare (ignorable o c)) + nil) +(defmethod input-files ((o prepare-op) (c component)) + (declare (ignorable o c)) + nil) +(defmethod input-files ((o prepare-op) (s system)) + (declare (ignorable o)) + (if-let (it (system-source-file s)) (list it))) + +;;; compile-op +(defmethod operation-description ((o compile-op) (c component)) + (declare (ignorable o)) + (format nil (compatfmt "~@") c)) +(defmethod operation-description ((o compile-op) (c parent-component)) + (declare (ignorable o)) + (format nil (compatfmt "~@") c)) +(defgeneric* call-with-around-compile-hook (component thunk)) +(defmethod call-with-around-compile-hook ((c component) function) + (call-around-hook (around-compile-hook c) function)) +(defun* perform-lisp-compilation (o c) + (let (;; Before 2.26.53, that was unfortunately component-pathname. Now, + ;; we consult input-files, the first of which should be the one to compile-file + (input-file (first (input-files o c))) + ;; on some implementations, there are more than one output-file, + ;; but the first one should always be the primary fasl that gets loaded. + (outputs (output-files o c))) + (multiple-value-bind (output warnings-p failure-p) + (destructuring-bind + (output-file + &optional + #+clisp lib-file + #+(or ecl mkcl) object-file + #+(or clozure sbcl) warnings-file) outputs + (call-with-around-compile-hook + c #'(lambda (&rest flags) + (with-muffled-compiler-conditions () + (apply 'compile-file* input-file + :output-file output-file + :external-format (component-external-format c) + (append + #+clisp (list :lib-file lib-file) + #+(or ecl mkcl) (list :object-file object-file) + #+(or clozure sbcl) (list :warnings-file warnings-file) + flags (compile-op-flags o))))))) + (check-lisp-compile-results output warnings-p failure-p + "~/asdf-action::format-action/" (list (cons o c)))))) + +(defun* report-file-p (f) + (equal (pathname-type f) "build-report")) +(defun* perform-lisp-warnings-check (o c) + (check-deferred-warnings + (remove-if-not #'warnings-file-p (input-files o c)) + "~/asdf-action::format-action/" (list (cons o c))) + (let* ((output (output-files o c)) + (report (find-if #'report-file-p output))) + (when report + (with-open-file (s report :direction :output :if-exists :supersede) + (format s ":success~%"))))) +(defmethod perform ((o compile-op) (c cl-source-file)) + (perform-lisp-compilation o c)) +(defmethod output-files ((o compile-op) (c cl-source-file)) + (declare (ignorable o)) + (let* ((i (first (input-files o c))) + (f (compile-file-pathname + i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl))) + `(,f ;; the fasl is the primary output, in first position + #+clisp + ,@`(,(make-pathname :type "lib" :defaults f)) + #+(or clozure sbcl) + ,@(let ((s (component-system c))) + (unless (builtin-system-p s) ; includes ASDF itself + `(,(make-pathname :type (warnings-file-type) :defaults f)))) + #+ecl + ,@(unless (use-ecl-byte-compiler-p) + `(,(compile-file-pathname i :type :object))) + #+mkcl + ,(compile-file-pathname i :fasl-p nil)))) ;; object file +(defmethod component-depends-on ((o compile-op) (c component)) + (declare (ignorable o)) + `((prepare-op ,c) ,@(call-next-method))) +(defmethod perform ((o compile-op) (c static-file)) + (declare (ignorable o c)) + nil) +(defmethod output-files ((o compile-op) (c static-file)) + (declare (ignorable o c)) + nil) +(defmethod perform ((o compile-op) (c system)) + (declare (ignorable o c)) + #+(or clozure sbcl) (perform-lisp-warnings-check o c)) +#+(or clozure sbcl) +(defmethod input-files ((o compile-op) (c system)) + (declare (ignorable o c)) + (unless (builtin-system-p c) + (loop* :for (sub-o . sub-c) + :in (traverse-sub-actions + o c :other-systems nil + :keep-operation 'compile-op :keep-component 'cl-source-file) + :append (remove-if-not 'warnings-file-p + (output-files sub-o sub-c))))) +#+sbcl +(defmethod output-files ((o compile-op) (c system)) + (unless (builtin-system-p c) + (if-let ((pathname (component-pathname c))) + (list (subpathname pathname (component-name c) :type "build-report"))))) + +;;; load-op +(defmethod operation-description ((o load-op) (c cl-source-file)) + (declare (ignorable o)) + (format nil (compatfmt "~@") c)) +(defmethod operation-description ((o load-op) (c parent-component)) + (declare (ignorable o)) + (format nil (compatfmt "~@") c)) +(defmethod operation-description ((o load-op) component) + (declare (ignorable o)) + (format nil (compatfmt "~@") + component)) +(defmethod perform-with-restarts ((o load-op) (c cl-source-file)) + (loop + (restart-case + (return (call-next-method)) + (try-recompiling () + :report (lambda (s) + (format s "Recompile ~a and try loading it again" + (component-name c))) + (perform (find-operation o 'compile-op) c))))) +(defun* perform-lisp-load-fasl (o c) + (if-let (fasl (first (input-files o c))) + (with-muffled-loader-conditions () (load* fasl)))) +(defmethod perform ((o load-op) (c cl-source-file)) + (perform-lisp-load-fasl o c)) +(defmethod perform ((o load-op) (c static-file)) + (declare (ignorable o c)) + nil) +(defmethod component-depends-on ((o load-op) (c component)) + (declare (ignorable o)) + ;; NB: even though compile-op depends-on on prepare-op, + ;; it is not needed-in-image-p, whereas prepare-op is, + ;; so better not omit prepare-op and think it will happen. + `((prepare-op ,c) (compile-op ,c) ,@(call-next-method))) -(defun inter-directory-separator () - (if (os-unix-p) #\: #\;)) -(defun* user-homedir () - (truenamize - (pathname-directory-pathname - #+cormanlisp (ensure-directory-pathname (user-homedir-pathname)) - #+mcl (current-user-homedir-pathname) - #-(or cormanlisp mcl) (user-homedir-pathname)))) +;;;; prepare-source-op, load-source-op -(defun* ensure-pathname* (x want-absolute want-directory fmt &rest args) - (when (plusp (length x)) - (let ((p (if want-directory (ensure-directory-pathname x) (pathname x)))) - (when want-absolute - (unless (absolute-pathname-p p) - (cerror "ignore relative pathname" - "Invalid relative pathname ~A~@[ ~?~]" x fmt args) - (return-from ensure-pathname* nil))) - p))) -(defun* split-pathnames* (x want-absolute want-directory fmt &rest args) - (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))) - (ensure-pathname* s want-absolute want-directory "from (getenv ~S)" 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) - (getenv-pathname x :want-absolute t :want-directory t)) -(defun* getenv-absolute-directories (x) - (getenv-pathnames x :want-absolute t :want-directory t)) +;;; prepare-source-op +(defmethod operation-description ((o prepare-source-op) (c component)) + (declare (ignorable o)) + (format nil (compatfmt "~@") c)) +(defmethod input-files ((o prepare-source-op) (c component)) + (declare (ignorable o c)) + nil) +(defmethod input-files ((o prepare-source-op) (s system)) + (declare (ignorable o)) + (if-let (it (system-source-file s)) (list it))) +(defmethod perform ((o prepare-source-op) (c component)) + (declare (ignorable o c)) + nil) -(defun* get-folder-path (folder) - (or ;; this semi-portably implements a subset of the functionality of lispworks' sys:get-folder-path - #+(and lispworks mswindows) (sys:get-folder-path folder) - ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData - (ecase folder - (:local-appdata (getenv-absolute-directory "LOCALAPPDATA")) - (:appdata (getenv-absolute-directory "APPDATA")) - (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA") - (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/")))))) +;;; load-source-op +(defmethod operation-description ((o load-source-op) c) + (declare (ignorable o)) + (format nil (compatfmt "~@") c)) +(defmethod operation-description ((o load-source-op) (c parent-component)) + (declare (ignorable o)) + (format nil (compatfmt "~@") c)) +(defmethod component-depends-on ((o load-source-op) (c component)) + (declare (ignorable o)) + `((prepare-source-op ,c) ,@(call-next-method))) +(defun* perform-lisp-load-source (o c) + (call-with-around-compile-hook + c #'(lambda () + (with-muffled-loader-conditions () + (load* (first (input-files o c)) + :external-format (component-external-format c)))))) -(defun* user-configuration-directories () - (let ((dirs - `(,@(when (os-unix-p) - (cons - (subpathname* (getenv-absolute-directory "XDG_CONFIG_HOME") "common-lisp/") - (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS") - :collect (subpathname* dir "common-lisp/")))) - ,@(when (os-windows-p) - `(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/") - ,(subpathname* (get-folder-path :appdata) "common-lisp/config/"))) - ,(subpathname (user-homedir) ".config/common-lisp/")))) - (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) - :from-end t :test 'equal))) +(defmethod perform ((o load-source-op) (c cl-source-file)) + (perform-lisp-load-source o c)) +(defmethod perform ((o load-source-op) (c static-file)) + (declare (ignorable o c)) + nil) +(defmethod output-files ((o load-source-op) (c component)) + (declare (ignorable o c)) + nil) -(defun* system-configuration-directories () - (cond - ((os-unix-p) '(#p"/etc/common-lisp/")) - ((os-windows-p) - (aif - ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData - (subpathname* (get-folder-path :common-appdata) "common-lisp/config/") - (list it))))) -(defun* in-first-directory (dirs x &key (direction :input)) - (loop :with fun = (ecase direction - ((nil :input :probe) 'probe-file*) - ((:output :io) 'identity)) - :for dir :in dirs - :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir)))))) +;;;; test-op +(defmethod perform ((o test-op) (c component)) + (declare (ignorable o c)) + nil) +(defmethod operation-done-p ((o test-op) (c system)) + "Testing a system is _never_ done." + (declare (ignorable o c)) + nil) +(defmethod component-depends-on ((o test-op) (c system)) + (declare (ignorable o)) + `((load-op ,c) ,@(call-next-method))) -(defun* in-user-configuration-directory (x &key (direction :input)) - (in-first-directory (user-configuration-directories) x :direction direction)) -(defun* in-system-configuration-directory (x &key (direction :input)) - (in-first-directory (system-configuration-directories) x :direction direction)) +;;;; ------------------------------------------------------------------------- +;;;; Plan -(defun* configuration-inheritance-directive-p (x) - (let ((kw '(:inherit-configuration :ignore-inherited-configuration))) - (or (member x kw) - (and (length=n-p x 1) (member (car x) kw))))) +(asdf/package:define-package :asdf/plan + (:recycle :asdf/plan :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/component :asdf/operation :asdf/system :asdf/find-system :asdf/find-component + :asdf/operation :asdf/action) + (:export + #:component-operation-time #:mark-operation-done + #:plan-traversal #:sequential-plan #:*default-plan-class* + #:planned-action-status #:plan-action-status #:action-already-done-p + #:circular-dependency #:circular-dependency-actions + #:node-for #:needed-in-image-p + #:action-index #:action-planned-p #:action-valid-p + #:plan-record-dependency #:visiting-action-p + #:normalize-forced-systems #:action-forced-p #:action-forced-not-p + #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies + #:visit-dependencies #:compute-action-stamp #:traverse-action + #:circular-dependency #:circular-dependency-actions + #:call-while-visiting-action #:while-visiting-action + #:traverse #:plan-actions #:perform-plan #:plan-operates-on-p + #:planned-p #:index #:forced #:forced-not #:total-action-count + #:planned-action-count #:planned-output-action-count #:visited-actions + #:visiting-action-set #:visiting-action-list #:plan-actions-r + #:required-components #:filtered-sequential-plan + #:plan-system + #:plan-action-filter #:plan-component-type #:plan-keep-operation #:plan-keep-component + #:traverse-actions #:traverse-sub-actions)) +(in-package :asdf/plan) + +;;;; Generic plan traversal class + +(defclass plan-traversal () + ((system :initform nil :initarg :system :accessor plan-system) + (forced :initform nil :initarg :force :accessor plan-forced) + (forced-not :initform nil :initarg :force-not :accessor plan-forced-not) + (total-action-count :initform 0 :accessor plan-total-action-count) + (planned-action-count :initform 0 :accessor plan-planned-action-count) + (planned-output-action-count :initform 0 :accessor plan-planned-output-action-count) + (visited-actions :initform (make-hash-table :test 'equal) :accessor plan-visited-actions) + (visiting-action-set :initform (make-hash-table :test 'equal) :accessor plan-visiting-action-set) + (visiting-action-list :initform () :accessor plan-visiting-action-list))) + + +;;;; Planned action status + +(defgeneric* plan-action-status (plan operation component) + (:documentation "Returns the ACTION-STATUS associated to +the action of OPERATION on COMPONENT in the PLAN")) + +(defgeneric* (setf plan-action-status) (new-status plan operation component) + (:documentation "Sets the ACTION-STATUS associated to +the action of OPERATION on COMPONENT in the PLAN")) + +(defclass planned-action-status (action-status) + ((planned-p + :initarg :planned-p :reader action-planned-p + :documentation "a boolean, true iff the action was included in the plan.") + (index + :initarg :index :reader action-index + :documentation "an integer, counting all traversed actions in traversal order.")) + (:documentation "Status of an action in a plan")) + +(defmethod print-object ((status planned-action-status) stream) + (print-unreadable-object (status stream :type t) + (with-slots (stamp done-p planned-p) status + (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p :planned-p planned-p)))) -(defun* report-invalid-form (reporter &rest args) - (etypecase reporter - (null - (apply 'error 'invalid-configuration args)) - (function - (apply reporter args)) - ((or symbol string) - (apply 'error reporter args)) - (cons - (apply 'apply (append reporter args))))) +(defmethod action-planned-p (action-status) + (declare (ignorable action-status)) ; default method for non planned-action-status objects + t) -(defvar *ignored-configuration-form* nil) +;; TODO: eliminate NODE-FOR, use CONS. +;; Supposes cleaner protocol for operation initargs passed to MAKE-OPERATION. +;; However, see also component-operation-time and mark-operation-done +(defun* node-for (o c) (cons (type-of o) c)) + +(defun* action-already-done-p (plan operation component) + (action-done-p (plan-action-status plan operation component))) + +(defmethod plan-action-status ((plan null) (o operation) (c component)) + (declare (ignorable plan)) + (multiple-value-bind (stamp done-p) (component-operation-time o c) + (make-instance 'action-status :stamp stamp :done-p done-p))) + +(defmethod (setf plan-action-status) (new-status (plan null) (o operation) (c component)) + (declare (ignorable plan)) + (let ((to (type-of o)) + (times (component-operation-times c))) + (if (action-done-p new-status) + (remhash to times) + (setf (gethash to times) (action-stamp new-status)))) + new-status) -(defun* validate-configuration-form (form tag directive-validator - &key location invalid-form-reporter) - (unless (and (consp form) (eq (car form) tag)) - (setf *ignored-configuration-form* t) - (report-invalid-form invalid-form-reporter :form form :location location) - (return-from validate-configuration-form nil)) - (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag) - :for directive :in (cdr form) - :when (cond - ((configuration-inheritance-directive-p directive) - (incf inherit) t) - ((eq directive :ignore-invalid-entries) - (setf ignore-invalid-p t) t) - ((funcall directive-validator directive) - t) - (ignore-invalid-p - nil) - (t - (setf *ignored-configuration-form* t) - (report-invalid-form invalid-form-reporter :form directive :location location) - nil)) - :do (push directive x) - :finally - (unless (= inherit 1) - (report-invalid-form invalid-form-reporter - :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 (compatfmt "~@~%") - description forms)) - (funcall validator (car forms) :location file))) +;;;; forcing -(defun* hidden-file-p (pathname) - (equal (first-char (pathname-name pathname)) #\.)) +(defgeneric* action-forced-p (plan operation component)) +(defgeneric* action-forced-not-p (plan operation component)) -(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) - #+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)))))) +(defun* normalize-forced-systems (x system) + (etypecase x + ((member nil :all) x) + (cons (list-to-hash-set (mapcar #'coerce-name x))) + ((eql t) (when system (list-to-hash-set (list (coerce-name system))))))) -(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter) - "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will -be applied to the results to yield a configuration form. Current -values of TAG include :source-registry and :output-translations." - (let ((files (sort (ignore-errors - (remove-if - 'hidden-file-p - (directory* (make-pathname :name :wild :type "conf" :defaults directory)))) - #'string< :key #'namestring))) - `(,tag - ,@(loop :for file :in files :append - (loop :with ignore-invalid-p = nil - :for form :in (read-file-forms file) - :when (eq form :ignore-invalid-entries) - :do (setf ignore-invalid-p t) - :else - :when (funcall validator form) - :collect form - :else - :when ignore-invalid-p - :do (setf *ignored-configuration-form* t) - :else - :do (report-invalid-form invalid-form-reporter :form form :location file))) - :inherit-configuration))) +(defun* action-override-p (plan operation component override-accessor) + (declare (ignorable operation)) + (let* ((override (funcall override-accessor plan))) + (and override + (if (typep override 'hash-table) + (gethash (coerce-name (component-system (find-component () component))) override) + t)))) + +(defmethod action-forced-p (plan operation component) + (and + ;; Did the user ask us to re-perform the action? + (action-override-p plan operation component 'plan-forced) + ;; You really can't force a builtin system and :all doesn't apply to it, + ;; except it it's the specifically the system currently being built. + (not (let ((system (component-system component))) + (and (builtin-system-p system) + (not (eq system (plan-system plan)))))))) + +(defmethod action-forced-not-p (plan operation component) + (and + ;; Did the user ask us to not re-perform the action? + (action-override-p plan operation component 'plan-forced-not) + ;; Force takes precedence over force-not + (not (action-forced-p plan operation component)))) + +(defmethod action-forced-p ((plan null) operation component) + (declare (ignorable plan operation component)) + nil) + +(defmethod action-forced-not-p ((plan null) operation component) + (declare (ignorable plan operation component)) + nil) + + +;;;; action-valid-p + +(defgeneric action-valid-p (plan operation component) + (:documentation "Is this action valid to include amongst dependencies?")) +(defmethod action-valid-p (plan operation (c component)) + (declare (ignorable plan operation)) + (if-let (it (component-if-feature c)) (featurep it) t)) +(defmethod action-valid-p (plan (o null) c) (declare (ignorable plan o c)) nil) +(defmethod action-valid-p (plan o (c null)) (declare (ignorable plan o c)) nil) +(defmethod action-valid-p ((plan null) operation component) + (declare (ignorable plan operation component)) + (and operation component t)) + + +;;;; Is the action needed in this image? + +(defgeneric* needed-in-image-p (operation component) + (:documentation "Is the action of OPERATION on COMPONENT needed in the current image to be meaningful, + or could it just as well have been done in another Lisp image?")) + +(defmethod needed-in-image-p ((o operation) (c component)) + ;; We presume that actions that modify the filesystem don't need be run + ;; in the current image if they have already been done in another, + ;; and can be run in another process (e.g. a fork), + ;; whereas those that don't are meant to side-effect the current image and can't. + (not (output-files o c))) + + +;;;; Visiting dependencies of an action and computing action stamps + +(defun* map-direct-dependencies (operation component fun) + (loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component) + :unless (eq dep-o-spec 'feature) ;; avoid the "FEATURE" misfeature + :do (loop :with dep-o = (find-operation operation dep-o-spec) + :for dep-c-spec :in dep-c-specs + :for dep-c = (resolve-dependency-spec component dep-c-spec) + :do (funcall fun dep-o dep-c)))) + +(defun* reduce-direct-dependencies (operation component combinator seed) + (map-direct-dependencies + operation component + #'(lambda (dep-o dep-c) + (setf seed (funcall combinator dep-o dep-c seed)))) + seed) + +(defun* direct-dependencies (operation component) + (reduce-direct-dependencies operation component #'acons nil)) + +(defun* visit-dependencies (plan operation component dependency-stamper &aux stamp) + (map-direct-dependencies + operation component + #'(lambda (dep-o dep-c) + (when (action-valid-p plan dep-o dep-c) + (latest-stamp-f stamp (funcall dependency-stamper dep-o dep-c))))) + stamp) + +(defmethod compute-action-stamp (plan (o operation) (c component) &key just-done) + ;; In a distant future, safe-file-write-date and component-operation-time + ;; shall also be parametrized by the plan, or by a second model object. + (let* ((stamp-lookup #'(lambda (o c) + (if-let (it (plan-action-status plan o c)) (action-stamp it) t))) + (out-files (output-files o c)) + (in-files (input-files o c)) + ;; Three kinds of actions: + (out-op (and out-files t)) ; those that create files on the filesystem + ;(image-op (and in-files (null out-files))) ; those that load stuff into the image + ;(null-op (and (null out-files) (null in-files))) ; dependency placeholders that do nothing + ;; When was the thing last actually done? (Now, or ask.) + (op-time (or just-done (component-operation-time o c))) + ;; Accumulated timestamp from dependencies (or T if forced or out-of-date) + (dep-stamp (visit-dependencies plan o c stamp-lookup)) + ;; Time stamps from the files at hand, and whether any is missing + (out-stamps (mapcar #'safe-file-write-date out-files)) + (in-stamps (mapcar #'safe-file-write-date in-files)) + (missing-in + (loop :for f :in in-files :for s :in in-stamps :unless s :collect f)) + (missing-out + (loop :for f :in out-files :for s :in out-stamps :unless s :collect f)) + (all-present (not (or missing-in missing-out))) + ;; Has any input changed since we last generated the files? + (earliest-out (stamps-earliest out-stamps)) + (latest-in (stamps-latest (cons dep-stamp in-stamps))) + (up-to-date-p (stamp<= latest-in earliest-out)) + ;; If everything is up to date, the latest of inputs and outputs is our stamp + (done-stamp (stamps-latest (cons latest-in out-stamps)))) + ;; Warn if some files are missing: + ;; either our model is wrong or some other process is messing with our files. + (when (and just-done (not all-present)) + (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~ + ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]" + (operation-description o c) + missing-in (length missing-in) (and missing-in missing-out) + missing-out (length missing-out))) + ;; Note that we use stamp<= instead of stamp< to play nice with generated files. + ;; Any race condition is intrinsic to the limited timestamp resolution. + (if (or just-done ;; The done-stamp is valid: if we're just done, or + ;; if all filesystem effects are up-to-date and there's no invalidating reason. + (and all-present up-to-date-p (operation-done-p o c) (not (action-forced-p plan o c)))) + (values done-stamp ;; return the hard-earned timestamp + (or just-done + (or out-op ;; a file-creating op is done when all files are up to date + ;; a image-effecting a placeholder op is done when it was actually run, + (and op-time (eql op-time done-stamp))))) ;; with the matching stamp + ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet + (values t nil)))) + +;;;; Generic support for plan-traversal + +(defgeneric* plan-record-dependency (plan operation component)) + +(defgeneric call-while-visiting-action (plan operation component function) + (:documentation "Detect circular dependencies")) + +(defmethod initialize-instance :after ((plan plan-traversal) + &key (force () fp) (force-not () fnp) system + &allow-other-keys) + (with-slots (forced forced-not) plan + (when fp (setf forced (normalize-forced-systems force system))) + (when fnp (setf forced-not (normalize-forced-systems force-not system))))) + +(defmethod (setf plan-action-status) (new-status (plan plan-traversal) (o operation) (c component)) + (setf (gethash (node-for o c) (plan-visited-actions plan)) new-status)) + +(defmethod plan-action-status ((plan plan-traversal) (o operation) (c component)) + (or (and (action-forced-not-p plan o c) (plan-action-status nil o c)) + (values (gethash (node-for o c) (plan-visited-actions plan))))) + +(defmethod action-valid-p ((plan plan-traversal) (o operation) (s system)) + (and (not (action-forced-not-p plan o s)) (call-next-method))) + +(defmethod call-while-visiting-action ((plan plan-traversal) operation component fun) + (with-accessors ((action-set plan-visiting-action-set) + (action-list plan-visiting-action-list)) plan + (let ((action (cons operation component))) + (when (gethash action action-set) + (error 'circular-dependency :actions + (member action (reverse action-list) :test 'equal))) + (setf (gethash action action-set) t) + (push action action-list) + (unwind-protect + (funcall fun) + (pop action-list) + (setf (gethash action action-set) nil))))) + + +;;;; Actual traversal: traverse-action + +(define-condition circular-dependency (system-definition-error) + ((actions :initarg :actions :reader circular-dependency-actions)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (circular-dependency-actions c))))) + +(defmacro while-visiting-action ((p o c) &body body) + `(call-while-visiting-action ,p ,o ,c #'(lambda () , at body))) + +(defgeneric* traverse-action (plan operation component needed-in-image-p)) + +(defmethod traverse-action (plan operation component needed-in-image-p) + (block nil + (unless (action-valid-p plan operation component) (return nil)) + (plan-record-dependency plan operation component) + (let* ((aniip (needed-in-image-p operation component)) + (eniip (and aniip needed-in-image-p)) + (status (plan-action-status plan operation component))) + (when (and status (or (action-done-p status) (action-planned-p status) (not eniip))) + ;; Already visited with sufficient need-in-image level: just return the stamp. + (return (action-stamp status))) + (labels ((visit-action (niip) + (visit-dependencies plan operation component + #'(lambda (o c) (traverse-action plan o c niip))) + (multiple-value-bind (stamp done-p) + (compute-action-stamp plan operation component) + (let ((add-to-plan-p (or (eql stamp t) (and niip (not done-p))))) + (cond + ((and add-to-plan-p (not niip)) ;; if we need to do it, + (visit-action t)) ;; then we need to do it in the image! + (t + (setf (plan-action-status plan operation component) + (make-instance + 'planned-action-status + :stamp stamp + :done-p (and done-p (not add-to-plan-p)) + :planned-p add-to-plan-p + :index (if status (action-index status) (incf (plan-total-action-count plan))))) + (when add-to-plan-p + (incf (plan-planned-action-count plan)) + (unless aniip + (incf (plan-planned-output-action-count plan)))) + stamp)))))) + (while-visiting-action (plan operation component) ; maintain context, handle circularity. + (visit-action eniip)))))) + + +;;;; Sequential plans (the default) + +(defclass sequential-plan (plan-traversal) + ((actions-r :initform nil :accessor plan-actions-r))) + +(defgeneric* plan-actions (plan)) +(defmethod plan-actions ((plan sequential-plan)) + (reverse (plan-actions-r plan))) + +(defmethod plan-record-dependency ((plan sequential-plan) + (operation operation) (component component)) + (declare (ignorable plan operation component)) + (values)) + +(defmethod (setf plan-action-status) :after + (new-status (p sequential-plan) (o operation) (c component)) + (when (action-planned-p new-status) + (push (cons o c) (plan-actions-r p)))) + + +;;;; high-level interface: traverse, perform-plan, plan-operates-on-p + +(defgeneric* (traverse) (operation component &key &allow-other-keys) + (:documentation +"Generate and return a plan for performing OPERATION on COMPONENT. + +The plan returned is a list of dotted-pairs. Each pair is the CONS +of ASDF operation object and a COMPONENT object. The pairs will be +processed in order by OPERATE.")) +(define-convenience-action-methods traverse (operation component &key)) + +(defgeneric* perform-plan (plan &key)) +(defgeneric* plan-operates-on-p (plan component)) + +(defparameter *default-plan-class* 'sequential-plan) + +(defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys) + (let ((plan (apply 'make-instance + (or plan-class *default-plan-class*) + :system (component-system c) (remove-plist-key :plan-class keys)))) + (traverse-action plan o c t) + (plan-actions plan))) + + +(defmethod perform-plan ((steps list) &key) + (let ((*package* *package*) + (*readtable* *readtable*)) + (loop* :for (op . component) :in steps :do + (perform-with-restarts op component)))) + +(defmethod plan-operates-on-p ((plan list) (component-path list)) + (find component-path (mapcar 'cdr plan) + :test 'equal :key 'component-find-path)) + + +;;;; Incidental traversals + +(defclass filtered-sequential-plan (sequential-plan) + ((action-filter :initform t :initarg :action-filter :reader plan-action-filter) + (component-type :initform t :initarg :component-type :reader plan-component-type) + (keep-operation :initform t :initarg :keep-operation :reader plan-keep-operation) + (keep-component :initform t :initarg :keep-component :reader plan-keep-component))) + +(defmethod initialize-instance :after ((plan filtered-sequential-plan) + &key (force () fp) (force-not () fnp) + other-systems) + (declare (ignore force force-not)) + (with-slots (forced forced-not action-filter system) plan + (unless fp (setf forced (normalize-forced-systems (if other-systems :all t) system))) + (unless fnp (setf forced-not (normalize-forced-systems (if other-systems nil :all) system))) + (setf action-filter (ensure-function action-filter)))) + +(defmethod action-valid-p ((plan filtered-sequential-plan) o c) + (and (funcall (plan-action-filter plan) o c) + (typep c (plan-component-type plan)) + (call-next-method))) + +(defmethod traverse-actions (actions &rest keys &key plan-class &allow-other-keys) + (let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-plan) keys))) + (loop* :for (o . c) :in actions :do + (traverse-action plan o c t)) + (plan-actions plan))) + +(defmethod traverse-sub-actions (operation component &rest keys &key &allow-other-keys) + (apply 'traverse-actions (direct-dependencies operation component) + :system (component-system component) keys)) + +(defmethod plan-actions ((plan filtered-sequential-plan)) + (with-slots (keep-operation keep-component) plan + (loop* :for (o . c) :in (call-next-method) + :when (and (typep o keep-operation) + (typep c keep-component)) + :collect (cons o c)))) + +(defmethod required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys) + (remove-duplicates + (mapcar 'cdr (apply 'traverse-sub-actions (make-operation goal-operation) system keys)) + :from-end t)) + +;;;; ------------------------------------------------------------------------- +;;;; Invoking Operations + +(asdf/package:define-package :asdf/operate + (:recycle :asdf/operate :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/component :asdf/system :asdf/operation :asdf/action + :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan) + (:export + #:operate #:oos + #:*systems-being-operated* #:*asdf-upgrade-already-attempted* + #:build-system + #:load-system #:load-systems #:compile-system #:test-system #:require-system + #:*load-system-operation* #:module-provide-asdf + #:component-loaded-p #:already-loaded-systems + #:upgrade-asdf #:cleanup-upgraded-asdf #:*post-upgrade-hook*)) +(in-package :asdf/operate) + +(defgeneric* (operate) (operation component &key &allow-other-keys)) +(define-convenience-action-methods + operate (operation component &key) + :operation-initargs t ;; backward-compatibility with ASDF1. Yuck. + :if-no-component (error 'missing-component :requires component)) + +(defvar *systems-being-operated* nil + "A boolean indicating that some systems are being operated on") + +(defmethod operate :around (operation component + &key verbose + (on-warnings *compile-file-warnings-behaviour*) + (on-failure *compile-file-failure-behaviour*) &allow-other-keys) + (declare (ignorable operation component)) + ;; Setup proper bindings around any operate call. + (with-system-definitions () + (let* ((*asdf-verbose* verbose) + (*verbose-out* (if verbose *standard-output* (make-broadcast-stream))) + (*compile-file-warnings-behaviour* on-warnings) + (*compile-file-failure-behaviour* on-failure)) + (call-next-method)))) + +(defmethod operate ((operation operation) (component component) + &rest args &key version &allow-other-keys) + "Operate does three things: + +1. It creates an instance of OPERATION-CLASS using any keyword parameters as initargs. +2. It finds the asdf-system specified by SYSTEM (possibly loading it from disk). +3. It then calls TRAVERSE with the operation and system as arguments + +The traverse operation is wrapped in WITH-COMPILATION-UNIT and error handling code. +If a VERSION argument is supplied, then operate also ensures that the system found +satisfies it using the VERSION-SATISFIES method. + +Note that dependencies may cause the operation to invoke other operations on the system +or its components: the new operations will be created with the same initargs as the original one. + +The :FORCE or :FORCE-NOT argument to OPERATE can be: + T to force the inside of the specified system to be rebuilt (resp. not), + without recursively forcing the other systems we depend on. + :ALL to force all systems including other systems we depend on to be rebuilt (resp. not). + (SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list +:FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced." + (let* (;; I'd like to remove-plist-keys :force :force-not :verbose, + ;; but swank.asd relies on :force (!). + (systems-being-operated *systems-being-operated*) + (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal))) + (system (component-system component))) + (setf (gethash (coerce-name system) *systems-being-operated*) system) + (unless (version-satisfies component version) + (error 'missing-component-of-version :requires component :version version)) + ;; Before we operate on any system, make sure ASDF is up-to-date, + ;; for if an upgrade is ever attempted at any later time, there may be BIG trouble. + (unless systems-being-operated + (let ((operation-name (reify-symbol (type-of operation))) + (component-path (component-find-path component))) + (when (upgrade-asdf) + ;; If we were upgraded, restart OPERATE the hardest of ways, for + ;; its function may have been redefined, its symbol uninterned, its package deleted. + (return-from operate + (apply (find-symbol* 'operate :asdf) + (unreify-symbol operation-name) + component-path args))))) + (let ((plan (apply 'traverse operation system args))) + (perform-plan plan) + (values operation plan)))) + +(defun* oos (operation component &rest args &key &allow-other-keys) + (apply 'operate operation component args)) + +(setf (documentation 'oos 'function) + (format nil "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a" + (documentation 'operate 'function))) + + +;;;; Common operations + +(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. + +This may change in the future as we will implement component-based strategy +for how to load or compile stuff") + +(defun* build-system (system &rest keys) + "Shorthand for `(operate 'asdf:build-op system)`." + (apply 'operate 'build-op system keys) + t) + +(defun* load-system (system &rest keys &key force force-not verbose version &allow-other-keys) + "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details." + (declare (ignore force force-not verbose version)) + (apply 'operate *load-system-operation* system keys) + t) + +(defun* load-systems (&rest systems) + "Loading multiple systems at once." + (map () 'load-system systems)) + +(defun* compile-system (system &rest args &key force force-not verbose version &allow-other-keys) + "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE for details." + (declare (ignore force force-not verbose version)) + (apply 'operate 'compile-op system args) + t) + +(defun* test-system (system &rest args &key force force-not verbose version &allow-other-keys) + "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for details." + (declare (ignore force force-not verbose version)) + (apply 'operate 'test-op system args) + t) + + +;;;; Define require-system, to be hooked into CL:REQUIRE when possible, +;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL + +(defun* component-loaded-p (c) + (action-already-done-p nil (make-instance 'load-op) (find-component c ()))) + +(defun* already-loaded-systems () + (remove-if-not 'component-loaded-p (registered-systems))) + +(defun* require-system (s &rest keys &key &allow-other-keys) + (apply 'load-system s :force-not (already-loaded-systems) keys)) + +(defun* module-provide-asdf (name) + (handler-bind + ((style-warning #'muffle-warning) + (missing-component (constantly nil)) + (error #'(lambda (e) + (format *error-output* (compatfmt "~@~%") + name e)))) + (let ((*verbose-out* (make-broadcast-stream)) + (system (find-system (string-downcase name) nil))) + (when system + (require-system system :verbose nil) + t)))) -;;; --------------------------------------------------------------------------- -;;; asdf-output-translations -;;; -;;; this code is heavily inspired from -;;; asdf-binary-translations, common-lisp-controller and cl-launch. -;;; --------------------------------------------------------------------------- +;;;; Some upgrade magic + +(defun* reset-asdf-systems () + (let ((asdf (find-system :asdf))) + (setf (component-version asdf) (asdf-version)) + ;; Invalidate all systems but ASDF itself. + (setf *defined-systems* (make-defined-systems-table)) + (register-system asdf) + (load-system asdf))) ;; re-load ourselves the right way + +(defun* restart-upgraded-asdf () + ;; If we're in the middle of something, restart it. + (when *systems-being-defined* + (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name))) + (clrhash *systems-being-defined*) + (dolist (s l) (find-system s nil))))) + +(pushnew 'reset-asdf-systems *post-upgrade-cleanup-hook*) +(pushnew 'restart-upgraded-asdf *post-upgrade-restart-hook*) +;;;; --------------------------------------------------------------------------- +;;;; asdf-output-translations + +(asdf/package:define-package :asdf/output-translations + (:recycle :asdf/output-translations :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade) + (:export + #:*output-translations* #:*output-translations-parameter* + #:invalid-output-translation + #:output-translations #:output-translations-initialized-p + #:initialize-output-translations #:clear-output-translations + #:disable-output-translations #:ensure-output-translations + #:apply-output-translations + #:validate-output-translations-directive #:validate-output-translations-form + #:validate-output-translations-file #:validate-output-translations-directory + #:parse-output-translations-string #:wrapping-output-translations + #:user-output-translations-pathname #:system-output-translations-pathname + #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname + #:environment-output-translations #:process-output-translations + #:compute-output-translations + )) +(in-package :asdf/output-translations) + +(when-upgrade () (undefine-function '(setf output-translations))) + +(define-condition invalid-output-translation (invalid-configuration warning) + ((format :initform (compatfmt "~@")))) (defvar *output-translations* () "Either NIL (for uninitialized), or a list of one element, @@ -3506,20 +7045,10 @@ Each mapping is a pair of a source pathname and destination pathname, and the order is by decreasing length of namestring of the source pathname.") -(defvar *user-cache* - (flet ((try (x &rest sub) (and x `(,x , at sub)))) - (or - (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation) - (when (os-windows-p) - (try (or (get-folder-path :local-appdata) - (get-folder-path :appdata)) - "common-lisp" "cache" :implementation)) - '(:home ".cache" "common-lisp" :implementation)))) - (defun* output-translations () (car *output-translations*)) -(defun* (setf output-translations) (new-value) +(defun* set-output-translations (new-value) (setf *output-translations* (list (stable-sort (copy-list new-value) #'> @@ -3530,131 +7059,16 @@ (let ((directory (pathname-directory (car x)))) (if (listp directory) (length directory) 0)))))))) new-value) +(defsetf output-translations set-output-translations) ; works with gcl 2.6 (defun* output-translations-initialized-p () (and *output-translations* t)) (defun* clear-output-translations () - "Undoes any initialization of the output translations. -You might want to call that before you dump an image that would be resumed -with a different configuration, so the configuration would be re-read then." + "Undoes any initialization of the output translations." (setf *output-translations* '()) (values)) - -(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)) - (values (or null pathname) &optional)) - resolve-location)) - -(defun* resolve-relative-location-component (x &key directory wilden) - (let ((r (etypecase x - (pathname x) - (string (coerce-pathname x :type (when directory :directory))) - (cons - (if (null (cdr x)) - (resolve-relative-location-component - (car x) :directory directory :wilden wilden) - (let* ((car (resolve-relative-location-component - (car x) :directory t :wilden nil))) - (merge-pathnames* - (resolve-relative-location-component - (cdr x) :directory directory :wilden wilden) - car)))) - ((eql :default-directory) - (relativize-pathname-directory (default-directory))) - ((eql :*/) *wild-directory*) - ((eql :**/) *wild-inferiors*) - ((eql :*.*.*) *wild-file*) - ((eql :implementation) - (coerce-pathname (implementation-identifier) :type :directory)) - ((eql :implementation-type) - (coerce-pathname (string-downcase (implementation-type)) :type :directory)) - ((eql :hostname) - (coerce-pathname (hostname) :type :directory))))) - (when (absolute-pathname-p r) - (error (compatfmt "~@") x)) - (if (or (pathnamep x) (not wilden)) r (wilden r)))) - -(defvar *here-directory* nil - "This special variable is bound to the currect directory during calls to -PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here -directive.") - -(defun* resolve-absolute-location-component (x &key directory wilden) - (let* ((r - (etypecase x - (pathname x) - (string (let ((p (#+mcl probe-posix #-mcl parse-namestring x))) - #+mcl (unless p (error "POSIX pathname ~S does not exist" x)) - (if directory (ensure-directory-pathname p) p))) - (cons - (return-from resolve-absolute-location-component - (if (null (cdr x)) - (resolve-absolute-location-component - (car x) :directory directory :wilden wilden) - (merge-pathnames* - (resolve-relative-location-component - (cdr x) :directory directory :wilden wilden) - (resolve-absolute-location-component - (car x) :directory t :wilden nil))))) - ((eql :root) - ;; special magic! we encode such paths as relative pathnames, - ;; but it means "relative to the root of the source pathname's host and device". - (return-from resolve-absolute-location-component - (let ((p (make-pathname :directory '(:relative)))) - (if wilden (wilden p) p)))) - ((eql :home) (user-homedir)) - ((eql :here) - (resolve-location (or *here-directory* - ;; give semantics in the case of use interactively - :default-directory) - :directory t :wilden nil)) - ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil)) - ((eql :system-cache) - (error "Using the :system-cache is deprecated. ~%~ -Please remove it from your ASDF configuration")) - ((eql :default-directory) (default-directory)))) - (s (if (and wilden (not (pathnamep x))) - (wilden r) - r))) - (unless (absolute-pathname-p s) - (error (compatfmt "~@") x)) - s)) - -(defun* resolve-location (x &key directory wilden) - (if (atom x) - (resolve-absolute-location-component x :directory directory :wilden wilden) - (loop :with path = (resolve-absolute-location-component - (car x) :directory (and (or directory (cdr x)) t) - :wilden (and wilden (null (cdr x)))) - :for (component . morep) :on (cdr x) - :for dir = (and (or morep directory) t) - :for wild = (and wilden (not morep)) - :do (setf path (merge-pathnames* - (resolve-relative-location-component - component :directory dir :wilden wild) - path)) - :finally (return path)))) - -(defun* location-designator-p (x) - (flet ((absolute-component-p (c) - (typep c '(or string pathname - (member :root :home :here :user-cache :system-cache :default-directory)))) - (relative-component-p (c) - (typep c '(or string pathname - (member :default-directory :*/ :**/ :*.*.* - :implementation :implementation-type))))) - (or (typep x 'boolean) - (absolute-component-p x) - (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x)))))) - -(defun* location-function-p (x) - (and - (length=n-p x 2) - (eq (car x) :function) - (or (symbolp (cadr x)) - (and (consp (cadr x)) - (eq (caadr x) 'lambda) - (length=n-p (cadadr x) 2))))) +(register-clear-configuration-hook 'clear-output-translations) (defun* validate-output-translations-directive (directive) (or (member directive '(:enable-user-cache :disable-cache nil)) @@ -3736,12 +7150,10 @@ `(:output-translations ;; Some implementations have precompiled ASDF systems, ;; so we must disable translations for implementation paths. - #+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 - #+(or ecl mkcl) (,(translate-logical-pathname "SYS:**;*.*") ()) + #+(or #|clozure|# ecl mkcl sbcl) + ,@(let ((h (resolve-symlinks* (lisp-implementation-directory)))) + (when h `(((,h ,*wild-path*) ())))) #+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 ;; These are for convenience, and can be overridden by the user: @@ -3750,8 +7162,8 @@ ;; We enable the user cache by default, and here is the place we do: :enable-user-cache)) -(defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf")) -(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/")) +(defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf")) +(defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/")) (defun* user-output-translations-pathname (&key (direction :input)) (in-user-configuration-directory *output-translations-file* :direction direction)) @@ -3765,40 +7177,12 @@ (getenv "ASDF_OUTPUT_TRANSLATIONS")) (defgeneric* process-output-translations (spec &key inherit collect)) -(declaim (ftype (function (t &key (:collect (or symbol function))) t) - inherit-output-translations)) -(declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t) - process-output-translations-directive)) - -(defmethod process-output-translations ((x symbol) &key - (inherit *default-output-translations*) - collect) - (process-output-translations (funcall x) :inherit inherit :collect collect)) -(defmethod process-output-translations ((pathname pathname) &key inherit collect) - (cond - ((directory-pathname-p pathname) - (process-output-translations (validate-output-translations-directory pathname) - :inherit inherit :collect collect)) - ((probe-file* pathname) - (process-output-translations (validate-output-translations-file pathname) - :inherit inherit :collect collect)) - (t - (inherit-output-translations inherit :collect collect)))) -(defmethod process-output-translations ((string string) &key inherit collect) - (process-output-translations (parse-output-translations-string string) - :inherit inherit :collect collect)) -(defmethod process-output-translations ((x null) &key inherit collect) - (declare (ignorable x)) - (inherit-output-translations inherit :collect collect)) -(defmethod process-output-translations ((form cons) &key inherit collect) - (dolist (directive (cdr (validate-output-translations-form form))) - (process-output-translations-directive directive :inherit inherit :collect collect))) (defun* inherit-output-translations (inherit &key collect) (when inherit (process-output-translations (first inherit) :collect collect :inherit (rest inherit)))) -(defun* process-output-translations-directive (directive &key inherit collect) +(defun* (process-output-translations-directive) (directive &key inherit collect) (if (atom directive) (ecase directive ((:enable-user-cache) @@ -3816,8 +7200,8 @@ (process-output-translations (pathname dst) :inherit nil :collect collect)) (when src (let ((trusrc (or (eql src t) - (let ((loc (resolve-location src :directory t :wilden t))) - (if (absolute-pathname-p loc) (truenamize loc) loc))))) + (let ((loc (resolve-location src :ensure-directory t :wilden t))) + (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc))))) (cond ((location-function-p dst) (funcall collect @@ -3829,12 +7213,35 @@ (funcall collect (list trusrc t))) (t (let* ((trudst (if dst - (resolve-location dst :directory t :wilden t) - trusrc)) - (wilddst (merge-pathnames* *wild-file* trudst))) - (funcall collect (list wilddst t)) + (resolve-location dst :ensure-directory t :wilden t) + trusrc))) + (funcall collect (list trudst t)) (funcall collect (list trusrc trudst))))))))))) +(defmethod process-output-translations ((x symbol) &key + (inherit *default-output-translations*) + collect) + (process-output-translations (funcall x) :inherit inherit :collect collect)) +(defmethod process-output-translations ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit collect) + (cond + ((directory-pathname-p pathname) + (process-output-translations (validate-output-translations-directory pathname) + :inherit inherit :collect collect)) + ((probe-file* pathname :truename *resolve-symlinks*) + (process-output-translations (validate-output-translations-file pathname) + :inherit inherit :collect collect)) + (t + (inherit-output-translations inherit :collect collect)))) +(defmethod process-output-translations ((string string) &key inherit collect) + (process-output-translations (parse-output-translations-string string) + :inherit inherit :collect collect)) +(defmethod process-output-translations ((x null) &key inherit collect) + (declare (ignorable x)) + (inherit-output-translations inherit :collect collect)) +(defmethod process-output-translations ((form cons) &key inherit collect) + (dolist (directive (cdr (validate-output-translations-form form))) + (process-output-translations-directive directive :inherit inherit :collect collect))) + (defun* compute-output-translations (&optional parameter) "read the configuration, return it" (remove-duplicates @@ -3866,30 +7273,14 @@ (output-translations) (initialize-output-translations))) -(defun* translate-pathname* (path absolute-source destination &optional root source) - (declare (ignore source)) - (cond - ((functionp destination) - (funcall destination path absolute-source)) - ((eq destination t) - path) - ((not (pathnamep destination)) - (error "Invalid destination")) - ((not (absolute-pathname-p destination)) - (translate-pathname path absolute-source (merge-pathnames* destination root))) - (root - (translate-pathname (directorize-pathname-host-device path) absolute-source destination)) - (t - (translate-pathname path absolute-source destination)))) - -(defun* apply-output-translations (path) - #+cormanlisp (truenamize path) #-cormanlisp +(defun* (apply-output-translations) (path) + #+cormanlisp (resolve-symlinks* path) #-cormanlisp (etypecase path (logical-pathname path) ((or pathname string) (ensure-output-translations) - (loop :with p = (truenamize path) + (loop* :with p = (resolve-symlinks* path) :for (source destination) :in (car *output-translations*) :for root = (when (or (eq source t) (and (pathnamep source) @@ -3903,62 +7294,8 @@ :return (translate-pathname* p absolute-source destination root source) :finally (return p))))) -(defmethod output-files :around (operation component) - "Translate output files, unless asked not to" - operation component ;; hush genera, not convinced by declare ignorable(!) - (values - (multiple-value-bind (files fixedp) (call-next-method) - (if fixedp - files - (mapcar #'apply-output-translations files))) - t)) - -(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) - (if (absolute-pathname-p output-file) - ;; what cfp should be doing, w/ mp* instead of mp - (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys))) - (defaults (make-pathname - :type type :defaults (merge-pathnames* input-file)))) - (merge-pathnames* output-file defaults)) - (apply-output-translations - (apply 'compile-file-pathname input-file - (if output-file keys (remove-keyword :output-file keys)))))) - -(defun* tmpize-pathname (x) - (make-pathname :name (strcat "ASDF-TMP-" (pathname-name x)) :defaults x)) - -(defun* delete-file-if-exists (x) - (when (and x (probe-file* x)) - (delete-file x))) - -(defun* compile-file* (input-file &rest keys &key compile-check output-file &allow-other-keys) - (let* ((keywords (remove-keyword :compile-check keys)) - (output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords)) - (tmp-file (tmpize-pathname output-file)) - (status :error)) - (multiple-value-bind (output-truename warnings-p failure-p) - (apply 'compile-file input-file :output-file tmp-file keywords) - (cond - (failure-p - (setf status *compile-file-failure-behaviour*)) - (warnings-p - (setf status *compile-file-warnings-behaviour*)) - (t - (setf status :success))) - (cond - ((and (ecase status - ((:success :warn :ignore) t) - ((:error nil))) - (or (not compile-check) - (apply compile-check input-file :output-file tmp-file keywords))) - (delete-file-if-exists output-file) - (when output-truename - (rename-file output-truename output-file) - (setf output-truename output-file))) - (t ;; error or failed check - (delete-file-if-exists output-truename) - (setf output-truename nil failure-p t))) - (values output-truename warnings-p failure-p)))) +;; Hook into asdf/driver's output-translation mechanism +(setf *output-translation-function* 'apply-output-translations) #+abcl (defun* translate-jar-pathname (source wildcard) @@ -3986,57 +7323,35 @@ (target (merge-pathnames* relative-source target-root))) (normalize-device (apply-output-translations target))))) - -;;;; ----------------------------------------------------------------- -;;;; Compatibility mode for ASDF-Binary-Locations - -(defmethod operate :before (operation-class system &rest args &key &allow-other-keys) - (declare (ignorable operation-class system args)) - (when (find-symbol* '#:output-files-for-system-and-operation :asdf) - (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using. -ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS, -which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS, -and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details. -In case you insist on preserving your previous A-B-L configuration, but -do not know how to achieve the same effect with A-O-T, you may use function -ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual; -call that function where you would otherwise have loaded and configured A-B-L."))) - -(defun* enable-asdf-binary-locations-compatibility - (&key - (centralize-lisp-binaries nil) - (default-toplevel-directory - (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ??? - (include-per-user-information nil) - (map-all-source-files (or #+(or clisp ecl mkcl) t nil)) - (source-to-target-mappings nil)) - #+(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 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*))) - (destination-directory - (if centralize-lisp-binaries - `(,default-toplevel-directory - ,@(when include-per-user-information - (cdr (pathname-directory (user-homedir)))) - :implementation ,*wild-inferiors*) - `(:root ,*wild-inferiors* :implementation)))) - (initialize-output-translations - `(:output-translations - , at source-to-target-mappings - #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) - #+abcl (#p"/___jar___file___root___/**/*.*" (, at destination-directory)) - ((:root ,*wild-inferiors* ,mapped-files) - (, at destination-directory ,mapped-files)) - (t t) - :ignore-inherited-configuration)))) - ;;;; ----------------------------------------------------------------- ;;;; Source Registry Configuration, by Francois-Rene Rideau ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 +(asdf/package:define-package :asdf/source-registry + (:recycle :asdf/source-registry :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/find-system) + (:export + #:*source-registry* #:*source-registry-parameter* #:*default-source-registries* + #:invalid-source-registry + #:source-registry #:source-registry-initialized-p + #:initialize-source-registry #:clear-source-registry #:*source-registry* + #:disable-source-registry #:ensure-source-registry #:*source-registry-parameter* + #:*default-source-registry-exclusions* #:*source-registry-exclusions* + #:*wild-asd* #:directory-asd-files #:register-asd-directory + #:collect-asds-in-directory #:collect-sub*directories-asd-files + #:validate-source-registry-directive #:validate-source-registry-form + #:validate-source-registry-file #:validate-source-registry-directory + #:parse-source-registry-string #:wrapping-source-registry #:default-source-registry + #:user-source-registry #:system-source-registry + #:user-source-registry-directory #:system-source-registry-directory + #:environment-source-registry #:process-source-registry + #:compute-source-registry #:flatten-source-registry + #:sysdef-source-registry-search)) +(in-package :asdf/source-registry) + +(define-condition invalid-source-registry (invalid-configuration warning) + ((format :initform (compatfmt "~@")))) + ;; Using ack 1.2 exclusions (defvar *default-source-registry-exclusions* '(".bzr" ".cdv" @@ -4055,102 +7370,19 @@ (typep *source-registry* 'hash-table)) (defun* clear-source-registry () - "Undoes any initialization of the source registry. -You might want to call that before you dump an image that would be resumed -with a different configuration, so the configuration would be re-read then." + "Undoes any initialization of the source registry." (setf *source-registry* nil) (values)) +(register-clear-configuration-hook 'clear-source-registry) (defparameter *wild-asd* - (make-pathname :directory nil :name *wild* :type "asd" :version :newest)) - -(defun* filter-logical-directory-results (directory entries merger) - (if (typep directory 'logical-pathname) - ;; Try hard to not resolve logical-pathname into physical pathnames; - ;; otherwise logical-pathname users/lovers will be disappointed. - ;; If directory* could use some implementation-dependent magic, - ;; we will have logical pathnames already; otherwise, - ;; we only keep pathnames for which specifying the name and - ;; translating the LPN commute. - (loop :for f :in entries - :for p = (or (and (typep f 'logical-pathname) f) - (let* ((u (ignore-errors (funcall merger f)))) - ;; The first u avoids a cumbersome (truename u) error. - ;; At this point f should already be a truename, - ;; but isn't quite in CLISP, for doesn't have :version :newest - (and u (equal (ignore-errors (truename u)) (truename f)) u))) - :when p :collect p) - entries)) - -(defun* directory-files (directory &optional (pattern *wild-file*)) - (let ((dir (pathname directory))) - (when (typep dir 'logical-pathname) - ;; Because of the filtering we do below, - ;; logical pathnames have restrictions on wild patterns. - ;; Not that the results are very portable when you use these patterns on physical pathnames. - (when (wild-pathname-p dir) - (error "Invalid wild pattern in logical directory ~S" directory)) - (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) - (error "Invalid file pattern ~S for logical directory ~S" pattern directory)) - (setf pattern (make-pathname-logical pattern (pathname-host dir)))) - (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir))))) - (filter-logical-directory-results - directory entries - #'(lambda (f) - (make-pathname :defaults dir - :name (make-pathname-component-logical (pathname-name f)) - :type (make-pathname-component-logical (pathname-type f)) - :version (make-pathname-component-logical (pathname-version f)))))))) - -(defun* directory-asd-files (directory) - (directory-files directory *wild-asd*)) - -(defun* subdirectories (directory) - (let* ((directory (ensure-directory-pathname directory)) - #-(or abcl cormanlisp genera xcl) - (wild (merge-pathnames* - #-(or abcl allegro cmu lispworks sbcl scl xcl) - *wild-directory* - #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" - directory)) - (dirs - #-(or abcl cormanlisp genera xcl) - (ignore-errors - (directory* wild . #.(or #+clozure '(:directories t :files nil) - #+mcl '(:directories t)))) - #+(or abcl xcl) (system:list-directory directory) - #+cormanlisp (cl::directory-subdirs directory) - #+genera (fs:directory-list directory)) - #+(or abcl allegro cmu genera lispworks sbcl scl xcl) - (dirs (loop :for x :in dirs - :for d = #+(or abcl xcl) (extensions:probe-directory x) - #+allegro (excl:probe-directory x) - #+(or cmu sbcl scl) (directory-pathname-p x) - #+genera (getf (cdr x) :directory) - #+lispworks (lw:file-directory-p x) - :when d :collect #+(or abcl allegro xcl) d - #+genera (ensure-directory-pathname (first x)) - #+(or cmu lispworks sbcl scl) x))) - (filter-logical-directory-results - directory dirs - (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory)) - '(:absolute)))) ; because allegro returns NIL for #p"FOO:" - #'(lambda (d) - (let ((dir (normalize-pathname-directory-component (pathname-directory d)))) - (and (consp dir) (consp (cdr dir)) - (make-pathname - :defaults directory :name nil :type nil :version nil - :directory (append prefix (make-pathname-component-logical (last dir))))))))))) - -(defun* collect-asds-in-directory (directory collect) - (map () collect (directory-asd-files directory))) + (make-pathname* :directory nil :name *wild* :type "asd")) -(defun* collect-sub*directories (directory collectp recursep collector) - (when (funcall collectp directory) - (funcall collector directory)) - (dolist (subdir (subdirectories directory)) - (when (funcall recursep subdir) - (collect-sub*directories subdir collectp recursep collector)))) +(defun* directory-asd-files (directory) + (directory-files directory *wild-asd*)) + +(defun* collect-asds-in-directory (directory collect) + (map () collect (directory-asd-files directory))) (defun* collect-sub*directories-asd-files (directory &key (exclude *default-source-registry-exclusions*) collect) @@ -4241,21 +7473,19 @@ system-source-registry-directory default-source-registry)) -(defparameter *source-registry-file* (coerce-pathname "source-registry.conf")) -(defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/")) +(defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf")) +(defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/")) (defun* wrapping-source-registry () `(:source-registry - #+ecl (:tree ,(translate-logical-pathname "SYS:")) + #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory))) #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:")) - #+sbcl (:tree ,(truenamize (getenv-pathname "SBCL_HOME" :want-directory t))) :inherit-configuration #+cmu (:tree #p"modules:") #+scl (:tree #p"file://modules/"))) (defun* default-source-registry () `(: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") @@ -4278,21 +7508,48 @@ (defun* environment-source-registry () (getenv "CL_SOURCE_REGISTRY")) -(defgeneric* process-source-registry (spec &key inherit register)) -(declaim (ftype (function (t &key (:register (or symbol function))) t) - inherit-source-registry)) -(declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t) - process-source-registry-directive)) +(defgeneric* (process-source-registry) (spec &key inherit register)) + +(defun* (inherit-source-registry) (inherit &key register) + (when inherit + (process-source-registry (first inherit) :register register :inherit (rest inherit)))) + +(defun* (process-source-registry-directive) (directive &key inherit register) + (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive)) + (ecase kw + ((:include) + (destructuring-bind (pathname) rest + (process-source-registry (resolve-location pathname) :inherit nil :register register))) + ((:directory) + (destructuring-bind (pathname) rest + (when pathname + (funcall register (resolve-location pathname :ensure-directory t))))) + ((:tree) + (destructuring-bind (pathname) rest + (when pathname + (funcall register (resolve-location pathname :ensure-directory t) + :recurse t :exclude *source-registry-exclusions*)))) + ((:exclude) + (setf *source-registry-exclusions* rest)) + ((:also-exclude) + (appendf *source-registry-exclusions* rest)) + ((:default-registry) + (inherit-source-registry '(default-source-registry) :register register)) + ((:inherit-configuration) + (inherit-source-registry inherit :register register)) + ((:ignore-inherited-configuration) + nil))) + nil) (defmethod process-source-registry ((x symbol) &key inherit register) (process-source-registry (funcall x) :inherit inherit :register register)) -(defmethod process-source-registry ((pathname pathname) &key inherit register) +(defmethod process-source-registry ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit register) (cond ((directory-pathname-p pathname) - (let ((*here-directory* (truenamize pathname))) + (let ((*here-directory* (resolve-symlinks* pathname))) (process-source-registry (validate-source-registry-directory pathname) :inherit inherit :register register))) - ((probe-file* pathname) + ((probe-file* pathname :truename *resolve-symlinks*) (let ((*here-directory* (pathname-directory-pathname pathname))) (process-source-registry (validate-source-registry-file pathname) :inherit inherit :register register))) @@ -4309,175 +7566,1218 @@ (dolist (directive (cdr (validate-source-registry-form form))) (process-source-registry-directive directive :inherit inherit :register register)))) -(defun* inherit-source-registry (inherit &key register) - (when inherit - (process-source-registry (first inherit) :register register :inherit (rest inherit)))) +(defun* flatten-source-registry (&optional parameter) + (remove-duplicates + (while-collecting (collect) + (with-pathname-defaults () ;; be location-independent + (inherit-source-registry + `(wrapping-source-registry + ,parameter + ,@*default-source-registries*) + :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. +(defun* compute-source-registry (&optional parameter (registry *source-registry*)) + (dolist (entry (flatten-source-registry parameter)) + (destructuring-bind (directory &key recurse exclude) entry + (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates + (register-asd-directory + directory :recurse recurse :exclude exclude :collect + #'(lambda (asd) + (let* ((name (pathname-name asd)) + (name (if (typep asd 'logical-pathname) + ;; logical pathnames are upper-case, + ;; at least in the CLHS and on SBCL, + ;; yet (coerce-name :foo) is lower-case. + ;; won't work well with (load-system "Foo") + ;; instead of (load-system 'foo) + (string-downcase name) + name))) + (cond + ((gethash name registry) ; already shadowed by something else + nil) + ((gethash name h) ; conflict at current level + (when *asdf-verbose* + (warn (compatfmt "~@") + directory recurse name (gethash name h) asd))) + (t + (setf (gethash name registry) asd) + (setf (gethash name h) asd)))))) + h))) + (values)) + +(defvar *source-registry-parameter* nil) + +(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*)) + ;; Record the parameter used to configure the registry + (setf *source-registry-parameter* parameter) + ;; Clear the previous registry database: + (setf *source-registry* (make-hash-table :test 'equal)) + ;; Do it! + (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 +;; the latter, initialize. ASDF will call this function at the start +;; of (asdf:find-system) to make sure the source registry is initialized. +;; However, it will do so *without* a parameter, at which point it +;; will be too late to provide a parameter to this function, though +;; you may override the configuration explicitly by calling +;; initialize-source-registry directly with your parameter. +(defun* ensure-source-registry (&optional parameter) + (unless (source-registry-initialized-p) + (initialize-source-registry parameter)) + (values)) + +(defun* sysdef-source-registry-search (system) + (ensure-source-registry) + (values (gethash (primary-system-name system) *source-registry*))) +;;;; ------------------------------------------------------------------------- +;;; Internal hacks for backward-compatibility + +(asdf/package:define-package :asdf/backward-internals + (:recycle :asdf/backward-internals :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/system :asdf/component :asdf/find-system :asdf/action) + (:export ;; for internal use + #:%refresh-component-inline-methods + #:%resolve-if-component-dep-fails + #:make-sub-operation)) +(in-package :asdf/backward-internals) + +;;;; Backward compatibility with "inline methods" + +(defparameter +asdf-methods+ + '(perform-with-restarts perform explain output-files operation-done-p)) + +(defun* %remove-component-inline-methods (component) + (dolist (name +asdf-methods+) + (map () + ;; 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)) + (component-inline-methods component))) + ;; clear methods, then add the new ones + (component-inline-methods component) nil) + +(defun* %define-component-inline-methods (ret rest) + (dolist (name +asdf-methods+) + (let ((keyword (intern (symbol-name name) :keyword))) + (loop :for data = rest :then (cddr data) + :for key = (first data) + :for value = (second data) + :while data + :when (eq key keyword) :do + (destructuring-bind (op qual (o c) &body body) value + (pushnew + (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret))) + , at body)) + (component-inline-methods ret))))))) + +(defun* %refresh-component-inline-methods (component rest) + (%remove-component-inline-methods component) + (%define-component-inline-methods component rest)) + +;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute +;; and the companion asdf:feature pseudo-dependency. +;; This won't recurse into dependencies to accumulate feature conditions. +;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL +;; (older than 1.1.2.20-fe6da9f) but won't suffice to load an old nibbles. +(defun* %resolve-if-component-dep-fails (if-component-dep-fails component) + (asdf-message "The system definition for ~S uses deprecated ~ + ASDF option :IF-COMPONENT-DEP-DAILS. ~ + Starting with ASDF 2.27, please use :IF-FEATURE instead" + (coerce-name (component-system component))) + ;; This only supports the pattern of use of the "feature" seen in the wild + (check-type component parent-component) + (check-type if-component-dep-fails (member :fail :ignore :try-next)) + (unless (eq if-component-dep-fails :fail) + (loop :with o = (make-instance 'compile-op) + :for c :in (component-children component) :do + (loop* :for (feature? feature) :in (component-depends-on o c) + :when (eq feature? 'feature) :do + (setf (component-if-feature c) feature))))) + +(when-upgrade (:when (fboundp 'make-sub-operation)) + (defun* make-sub-operation (c o dep-c dep-o) + (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error))) +;;;; ------------------------------------------------------------------------- +;;;; Defsystem + +(asdf/package:define-package :asdf/defsystem + (:recycle :asdf/defsystem :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/component :asdf/system + :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate + :asdf/backward-internals) + (:export + #:defsystem #:register-system-definition + #:class-for-type #:*default-component-class* + #:determine-system-directory #:parse-component-form + #:duplicate-names #:sysdef-error-component #:check-component-input)) +(in-package :asdf/defsystem) + +;;; Pathname + +(defun* determine-system-directory (pathname) + ;; The defsystem macro calls this function to determine + ;; the pathname of a system as follows: + ;; 1. if the pathname argument is an pathname object (NOT a namestring), + ;; that is already an absolute pathname, return it. + ;; 2. otherwise, the directory containing the LOAD-PATHNAME + ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and + ;; if it is indeed available and an absolute pathname, then + ;; the PATHNAME argument is normalized to a relative pathname + ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T) + ;; and merged into that DIRECTORY as per SUBPATHNAME. + ;; Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded, + ;; and may be from within the EVAL-WHEN of a file compilation. + ;; If no absolute pathname was found, we return NIL. + (check-type pathname (or null string pathname)) + (let ((pathname (parse-unix-namestring pathname :type :directory)) + (load-pathname (load-pathname))) + (when (or pathname load-pathname) + (pathname-directory-pathname + (absolutize-pathnames + (list pathname load-pathname *default-pathname-defaults* (getcwd)) + :resolve-symlinks *resolve-symlinks*))))) + + +;;; Component class + +(defvar *default-component-class* 'cl-source-file) + +(defun* class-for-type (parent type) + (or (loop :for symbol :in (list + type + (find-symbol* type *package* nil) + (find-symbol* type :asdf/interface nil)) + :for class = (and symbol (find-class* symbol nil)) + :when (and class + (#-cormanlisp subtypep #+cormanlisp cl::subclassp + class (find-class* 'component))) + :return class) + (and (eq type :file) + (find-class* + (or (loop :for p = parent :then (component-parent p) :while p + :thereis (module-default-component-class p)) + *default-component-class*) nil)) + (sysdef-error "don't recognize component type ~A" type))) + + +;;; Check inputs + +(define-condition duplicate-names (system-definition-error) + ((name :initarg :name :reader duplicate-names-name)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (duplicate-names-name c))))) + +(defun* sysdef-error-component (msg type name value) + (sysdef-error (strcat msg (compatfmt "~&~@")) + type name value)) + +(defun* check-component-input (type name weakly-depends-on + depends-on components) + "A partial test of the values of a component." + (unless (listp depends-on) + (sysdef-error-component ":depends-on must be a list." + type name depends-on)) + (unless (listp weakly-depends-on) + (sysdef-error-component ":weakly-depends-on must be a list." + type name weakly-depends-on)) + (unless (listp components) + (sysdef-error-component ":components must be NIL or a list of components." + type name components))) + +(defun* normalize-version (form pathname) + (etypecase form + ((or string null) form) + (cons + (ecase (first form) + ((:read-file-form) + (destructuring-bind (subpath &key (at 0)) (rest form) + (safe-read-file-form (subpathname pathname subpath) :at at))))))) + + +;;; Main parsing function + +(defun* parse-component-form (parent options &key previous-serial-component) + (destructuring-bind + (type name &rest rest &key + ;; the following list of keywords is reproduced below in the + ;; remove-plist-keys form. important to keep them in sync + components pathname perform explain output-files operation-done-p + weakly-depends-on depends-on serial + do-first if-component-dep-fails (version nil versionp) + ;; list ends + &allow-other-keys) options + (declare (ignorable perform explain output-files operation-done-p)) + (check-component-input type name weakly-depends-on depends-on components) + (when (and parent + (find-component parent name) + (not ;; ignore the same object when rereading the defsystem + (typep (find-component parent name) + (class-for-type parent type)))) + (error 'duplicate-names :name name)) + (when do-first (error "DO-FIRST is not supported anymore as of ASDF 2.27")) + (let* ((args `(:name ,(coerce-name name) + :pathname ,pathname + ,@(when parent `(:parent ,parent)) + ,@(remove-plist-keys + '(:components :pathname :if-component-dep-fails :version + :perform :explain :output-files :operation-done-p + :weakly-depends-on :depends-on :serial) + rest))) + (component (find-component parent name))) + (when weakly-depends-on + ;; ASDF3: deprecate this feature and remove it. + (appendf depends-on + (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on))) + (when previous-serial-component + (push previous-serial-component depends-on)) + (if component ; preserve identity + (apply 'reinitialize-instance component args) + (setf component (apply 'make-instance (class-for-type parent type) args))) + (component-pathname component) ; eagerly compute the absolute pathname + (let ((sysdir (system-source-directory (component-system component)))) ;; requires the previous + (setf version (normalize-version version sysdir))) + (when (and versionp version (not (parse-version version nil))) + (warn (compatfmt "~@") + version name parent)) + (setf (component-version component) version) + (when (typep component 'parent-component) + (setf (component-children component) + (loop + :with previous-component = nil + :for c-form :in components + :for c = (parse-component-form component c-form + :previous-serial-component previous-component) + :for name = (component-name c) + :collect c + :when serial :do (setf previous-component name))) + (compute-children-by-name component)) + ;; Used by POIU. ASDF3: rename to component-depends-on + (setf (component-sibling-dependencies component) depends-on) + (%refresh-component-inline-methods component rest) + (when if-component-dep-fails + (%resolve-if-component-dep-fails if-component-dep-fails component)) + component))) + +(defun* register-system-definition + (name &rest options &key pathname (class 'system) (source-file () sfp) + defsystem-depends-on &allow-other-keys) + ;; The system must be registered before we parse the body, + ;; otherwise we recur when trying to find an existing system + ;; of the same name to reuse options (e.g. pathname) from. + ;; To avoid infinite recursion in cases where you defsystem a system + ;; that is registered to a different location to find-system, + ;; we also need to remember it in a special variable *systems-being-defined*. + (with-system-definitions () + (let* ((name (coerce-name name)) + (source-file (if sfp source-file (resolve-symlinks* (load-pathname)))) + (registered (system-registered-p name)) + (registered! (if registered + (rplaca registered (safe-file-write-date source-file)) + (register-system + (make-instance 'system :name name :source-file source-file)))) + (system (reset-system (cdr registered!) + :name name :source-file source-file)) + (component-options (remove-plist-key :class options))) + (apply 'load-systems defsystem-depends-on) + ;; We change-class AFTER we loaded the defsystem-depends-on + ;; since the class might be defined as part of those. + (let ((class (class-for-type nil class))) + (unless (eq (type-of system) class) + (change-class system class))) + (parse-component-form + nil (list* + :module name + :pathname (determine-system-directory pathname) + component-options))))) + +(defmacro defsystem (name &body options) + `(apply 'register-system-definition ',name ',options)) +;;;; ------------------------------------------------------------------------- +;;;; ASDF-Bundle + +(asdf/package:define-package :asdf/bundle + (:recycle :asdf/bundle :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation + :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate) + (:export + #:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system #:bundle-pathname-type + #:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op + #:monolithic-op #:monolithic-bundle-op #:direct-dependency-files + #:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op + #:program-op + #:compiled-file #:precompiled-system #:prebuilt-system + #:operation-monolithic-p + #:user-system-p #:user-system #:trivial-system-p + #+ecl #:make-build + #:register-pre-built-system + #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library + #:component-entry-point #:entry-point)) +(in-package :asdf/bundle) + +(defclass bundle-op (operation) + ((build-args :initarg :args :initform nil :accessor bundle-op-build-args) + (name-suffix :initarg :name-suffix :initform nil) + (bundle-type :initform :no-output-file :reader bundle-type) + #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files) + #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p) + #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p))) + +(defclass fasl-op (bundle-op) + ;; create a single fasl for the entire library + ((bundle-type :initform :fasl))) + +(defclass load-fasl-op (basic-load-op) + ;; load a single fasl for the entire library + ()) + +(defclass lib-op (bundle-op) + ;; On ECL: compile the system and produce linkable .a library for it. + ;; On others: just compile the system. + ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file))) + +(defclass dll-op (bundle-op) + ;; Link together all the dynamic library used by this system into a single one. + ((bundle-type :initform :dll))) + +(defclass binary-op (bundle-op) + ;; On ECL: produce lib and fasl for the system. + ;; On "normal" Lisps: produce just the fasl. + ()) + +(defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies + +(defclass monolithic-bundle-op (monolithic-op bundle-op) + ((prologue-code :accessor monolithic-op-prologue-code) + (epilogue-code :accessor monolithic-op-epilogue-code))) + +(defclass monolithic-binary-op (binary-op monolithic-bundle-op) + ;; On ECL: produce lib and fasl for combined system and dependencies. + ;; On "normal" Lisps: produce an image file from system and dependencies. + ()) + +(defclass monolithic-fasl-op (monolithic-bundle-op fasl-op) + ;; Create a single fasl for the system and its dependencies. + ()) + +(defclass monolithic-lib-op (monolithic-bundle-op lib-op) + ;; ECL: Create a single linkable library for the system and its dependencies. + ((bundle-type :initform :lib))) + +(defclass monolithic-dll-op (monolithic-bundle-op dll-op) + ((bundle-type :initform :dll))) + +(defclass program-op (monolithic-bundle-op) + ;; All: create an executable file from the system and its dependencies + ((bundle-type :initform :program))) + +(defgeneric* component-entry-point (component)) + +(defmethod component-entry-point ((c component)) + (declare (ignorable c)) + nil) + +(defclass bundle-system (system) + ((entry-point + :initform nil :initarg :entry-point :accessor component-entry-point))) + +(defun* bundle-pathname-type (bundle-type) + (etypecase bundle-type + ((eql :no-output-file) nil) ;; should we error out instead? + ((or null string) bundle-type) + ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb") + #+ecl + ((member :binary :dll :lib :static-library :program :object :program) + (compile-file-type :type bundle-type)) + ((eql :binary) "image") + ((eql :dll) (cond ((os-unix-p) "so") ((os-windows-p) "dll"))) + ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib"))) + ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe"))))) + +(defun* bundle-output-files (o c) + (let ((bundle-type (bundle-type o))) + (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type. + (let ((name (or (component-build-pathname c) + (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix)))) + (type (bundle-pathname-type bundle-type))) + (values (list (subpathname (component-pathname c) name :type type)) + (eq (type-of o) (component-build-operation c))))))) + +(defmethod output-files ((o bundle-op) (c system)) + (bundle-output-files o c)) + +#-(or ecl mkcl) +(progn + (defmethod perform ((o program-op) (c system)) + (let ((output-file (output-file o c))) + (setf *image-entry-point* (ensure-function (component-entry-point c))) + (dump-image output-file :executable t))) + + (defmethod perform ((o monolithic-binary-op) (c system)) + (let ((output-file (output-file o c))) + (dump-image output-file)))) + +(defclass compiled-file (file-component) + ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb"))) + +(defclass precompiled-system (system) + ((build-pathname :initarg :fasl))) + +(defclass prebuilt-system (system) + ((build-pathname :initarg :static-library :initarg :lib + :accessor prebuilt-system-static-library))) + +;;; +;;; BUNDLE-OP +;;; +;;; This operation takes all components from one or more systems and +;;; creates a single output file, which may be +;;; a FASL, a statically linked library, a shared library, etc. +;;; The different targets are defined by specialization. +;;; + +(defun* operation-monolithic-p (op) + (typep op 'monolithic-op)) + +(defmethod initialize-instance :after ((instance bundle-op) &rest initargs + &key (name-suffix nil name-suffix-p) + &allow-other-keys) + (declare (ignorable initargs name-suffix)) + (unless name-suffix-p + (setf (slot-value instance 'name-suffix) + (unless (typep instance 'program-op) + (if (operation-monolithic-p instance) ".all-systems" #-ecl ".system")))) + (when (typep instance 'monolithic-bundle-op) + (destructuring-bind (&rest original-initargs + &key lisp-files prologue-code epilogue-code + &allow-other-keys) + (operation-original-initargs instance) + (setf (operation-original-initargs instance) + (remove-plist-keys '(:lisp-files :epilogue-code :prologue-code) original-initargs) + (monolithic-op-prologue-code instance) prologue-code + (monolithic-op-epilogue-code instance) epilogue-code) + #-ecl (assert (null (or lisp-files epilogue-code prologue-code))) + #+ecl (setf (bundle-op-lisp-files instance) lisp-files))) + (setf (bundle-op-build-args instance) + (remove-plist-keys '(:type :monolithic :name-suffix) + (operation-original-initargs instance)))) + +(defmethod bundle-op-build-args :around ((o lib-op)) + (declare (ignorable o)) + (let ((args (call-next-method))) + (remf args :ld-flags) + args)) + +(defun* bundlable-file-p (pathname) + (let ((type (pathname-type pathname))) + (declare (ignorable type)) + (or #+ecl (or (equal type (compile-file-type :type :object)) + (equal type (compile-file-type :type :static-library))) + #+mkcl (equal type (compile-file-type :fasl-p nil)) + #+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equal type (compile-file-type))))) + +(defgeneric* (trivial-system-p) (component)) + +(defun* user-system-p (s) + (and (typep s 'system) + (not (builtin-system-p s)) + (not (trivial-system-p s)))) + +(deftype user-system () '(and system (satisfies user-system-p))) + +;;; +;;; First we handle monolithic bundles. +;;; These are standalone systems which contain everything, +;;; including other ASDF systems required by the current one. +;;; A PROGRAM is always monolithic. +;;; +;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL +;;; + +(defmethod component-depends-on ((o monolithic-lib-op) (c system)) + (declare (ignorable o)) + `((lib-op ,@(required-components c :other-systems t :component-type 'system + :goal-operation 'load-op + :keep-operation 'compile-op)))) + +(defmethod component-depends-on ((o monolithic-fasl-op) (c system)) + (declare (ignorable o)) + `((fasl-op ,@(required-components c :other-systems t :component-type 'system + :goal-operation 'load-fasl-op + :keep-operation 'fasl-op)))) + +(defmethod component-depends-on ((o program-op) (c system)) + (declare (ignorable o)) + #+(or ecl mkcl) (component-depends-on (make-operation 'monolithic-lib-op) c) + #-(or ecl mkcl) `((load-op ,c))) + +(defmethod component-depends-on ((o binary-op) (c system)) + (declare (ignorable o)) + `((fasl-op ,c) + (lib-op ,c))) + +(defmethod component-depends-on ((o monolithic-binary-op) (c system)) + `((,(find-operation o 'monolithic-fasl-op) ,c) + (,(find-operation o 'monolithic-lib-op) ,c))) + +(defmethod component-depends-on ((o lib-op) (c system)) + (declare (ignorable o)) + `((compile-op ,@(required-components c :other-systems nil :component-type '(not system) + :goal-operation 'load-op + :keep-operation 'compile-op)))) + +(defmethod component-depends-on ((o fasl-op) (c system)) + (declare (ignorable o)) + #+ecl `((lib-op ,c)) + #-ecl + (component-depends-on (find-operation o 'lib-op) c)) -(defun* process-source-registry-directive (directive &key inherit register) - (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive)) - (ecase kw - ((:include) - (destructuring-bind (pathname) rest - (process-source-registry (resolve-location pathname) :inherit nil :register register))) - ((:directory) - (destructuring-bind (pathname) rest - (when pathname - (funcall register (resolve-location pathname :directory t))))) - ((:tree) - (destructuring-bind (pathname) rest - (when pathname - (funcall register (resolve-location pathname :directory t) - :recurse t :exclude *source-registry-exclusions*)))) - ((:exclude) - (setf *source-registry-exclusions* rest)) - ((:also-exclude) - (appendf *source-registry-exclusions* rest)) - ((:default-registry) - (inherit-source-registry '(default-source-registry) :register register)) - ((:inherit-configuration) - (inherit-source-registry inherit :register register)) - ((:ignore-inherited-configuration) - nil))) +(defmethod component-depends-on ((o dll-op) c) + (component-depends-on (find-operation o 'lib-op) c)) + +(defmethod component-depends-on ((o bundle-op) c) + (declare (ignorable o c)) nil) -(defun* flatten-source-registry (&optional parameter) - (remove-duplicates - (while-collecting (collect) - (let ((*default-pathname-defaults* (default-directory))) - (inherit-source-registry - `(wrapping-source-registry - ,parameter - ,@*default-source-registries*) - :register #'(lambda (directory &key recurse exclude) - (collect (list directory :recurse recurse :exclude exclude)))))) - :test 'equal :from-end t)) +(defmethod component-depends-on :around ((o bundle-op) (c component)) + (declare (ignorable o c)) + (if-let (op (and (eq (type-of o) 'bundle-op) (component-build-operation c))) + `((,op ,c)) + (call-next-method))) + +(defun* direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys) + (while-collecting (collect) + (map-direct-dependencies + o c #'(lambda (sub-o sub-c) + (loop :for f :in (funcall key sub-o sub-c) + :when (funcall test f) :do (collect f)))))) + +(defmethod input-files ((o bundle-op) (c system)) + (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files)) + +(defun* select-bundle-operation (type &optional monolithic) + (ecase type + ((:binary) + (if monolithic 'monolithic-binary-op 'binary-op)) + ((:dll :shared-library) + (if monolithic 'monolithic-dll-op 'dll-op)) + ((:lib :static-library) + (if monolithic 'monolithic-lib-op 'lib-op)) + ((:fasl) + (if monolithic 'monolithic-fasl-op 'fasl-op)) + ((:program) + 'program-op))) + +(defun* make-build (system &rest args &key (monolithic nil) (type :fasl) + (move-here nil move-here-p) + &allow-other-keys) + (let* ((operation-name (select-bundle-operation type monolithic)) + (move-here-path (if (and move-here + (typep move-here '(or pathname string))) + (pathname move-here) + (merge-pathnames "./asdf-output/"))) + (operation (apply #'operate operation-name + system + (remove-plist-keys '(:monolithic :type :move-here) args))) + (system (find-system system)) + (files (and system (output-files operation system)))) + (if (or move-here (and (null move-here-p) + (member operation-name '(:program :binary)))) + (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path)) + :for f :in files + :for new-f = (make-pathname :name (pathname-name f) + :type (pathname-type f) + :defaults dest-path) + :do (rename-file-overwriting-target f new-f) + :collect new-f) + files))) -;; Will read the configuration and initialize all internal variables. -(defun* compute-source-registry (&optional parameter (registry *source-registry*)) - (dolist (entry (flatten-source-registry parameter)) - (destructuring-bind (directory &key recurse exclude) entry - (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates - (register-asd-directory - directory :recurse recurse :exclude exclude :collect - #'(lambda (asd) - (let* ((name (pathname-name asd)) - (name (if (typep asd 'logical-pathname) - ;; logical pathnames are upper-case, - ;; at least in the CLHS and on SBCL, - ;; yet (coerce-name :foo) is lower-case. - ;; won't work well with (load-system "Foo") - ;; instead of (load-system 'foo) - (string-downcase name) - name))) - (cond - ((gethash name registry) ; already shadowed by something else - nil) - ((gethash name h) ; conflict at current level - (when *asdf-verbose* - (warn (compatfmt "~@") - directory recurse name (gethash name h) asd))) - (t - (setf (gethash name registry) asd) - (setf (gethash name h) asd)))))) - h))) - (values)) +;;; +;;; LOAD-FASL-OP +;;; +;;; This is like ASDF's LOAD-OP, but using monolithic fasl files. +;;; -(defvar *source-registry-parameter* nil) +(defmethod component-depends-on ((o load-fasl-op) (c system)) + (declare (ignorable o)) + `((,o ,@(loop :for dep :in (component-sibling-dependencies c) + :collect (resolve-dependency-spec c dep))) + (,(if (user-system-p c) 'fasl-op 'load-op) ,c) + ,@(call-next-method))) + +(defmethod input-files ((o load-fasl-op) (c system)) + (when (user-system-p c) + (output-files (find-operation o 'fasl-op) c))) -(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*)) - (setf *source-registry-parameter* parameter) - (setf *source-registry* (make-hash-table :test 'equal)) - (compute-source-registry parameter)) +(defmethod perform ((o load-fasl-op) c) + (declare (ignorable o c)) + nil) -;; Checks an initial variable to see whether the state is initialized -;; or cleared. In the former case, return current configuration; in -;; the latter, initialize. ASDF will call this function at the start -;; of (asdf:find-system) to make sure the source registry is initialized. -;; However, it will do so *without* a parameter, at which point it -;; will be too late to provide a parameter to this function, though -;; you may override the configuration explicitly by calling -;; initialize-source-registry directly with your parameter. -(defun* ensure-source-registry (&optional parameter) - (unless (source-registry-initialized-p) - (initialize-source-registry parameter)) - (values)) +(defmethod perform ((o load-fasl-op) (c system)) + (perform-lisp-load-fasl o c)) -(defun* sysdef-source-registry-search (system) - (ensure-source-registry) - (values (gethash (coerce-name system) *source-registry*))) +(defmethod mark-operation-done :after ((o load-fasl-op) (c system)) + (mark-operation-done (find-operation o 'load-op) c)) -(defun* clear-configuration () - (clear-source-registry) - (clear-output-translations)) +;;; +;;; PRECOMPILED FILES +;;; +;;; This component can be used to distribute ASDF systems in precompiled form. +;;; Only useful when the dependencies have also been precompiled. +;;; + +(defmethod trivial-system-p ((s system)) + (every #'(lambda (c) (typep c 'compiled-file)) (component-children s))) +(defmethod output-files (o (c compiled-file)) + (declare (ignorable o c)) + nil) +(defmethod input-files (o (c compiled-file)) + (declare (ignorable o)) + (component-pathname c)) +(defmethod perform ((o load-op) (c compiled-file)) + (perform-lisp-load-fasl o c)) +(defmethod perform ((o load-source-op) (c compiled-file)) + (perform (find-operation o 'load-op) c)) +(defmethod perform ((o load-fasl-op) (c compiled-file)) + (perform (find-operation o 'load-op) c)) +(defmethod perform (o (c compiled-file)) + (declare (ignorable o c)) + nil) -;;; ECL and MKCL support for COMPILE-OP / LOAD-OP ;;; -;;; 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. +;;; Pre-built systems +;;; +(defmethod trivial-system-p ((s prebuilt-system)) + (declare (ignorable s)) + t) + +(defmethod perform ((o lib-op) (c prebuilt-system)) + (declare (ignorable o c)) + nil) + +(defmethod component-depends-on ((o lib-op) (c prebuilt-system)) + (declare (ignorable o c)) + nil) + +(defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system)) + (declare (ignorable o)) + nil) + + ;;; -;;; 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. +;;; PREBUILT SYSTEM CREATOR ;;; -;;; Also, register-pre-built-system. -#+(or ecl mkcl) + +(defmethod output-files ((o binary-op) (s system)) + (list (make-pathname :name (component-name s) :type "asd" + :defaults (component-pathname s)))) + +(defmethod perform ((o binary-op) (s system)) + (let* ((dependencies (component-depends-on o s)) + (fasl (first (apply #'output-files (first dependencies)))) + (library (first (apply #'output-files (second dependencies)))) + (asd (first (output-files o s))) + (name (pathname-name asd)) + (name-keyword (intern (string name) (find-package :keyword)))) + (with-open-file (s asd :direction :output :if-exists :supersede + :if-does-not-exist :create) + (format s ";;; Prebuilt ASDF definition for system ~A" name) + (format s ";;; Built for ~A ~A on a ~A/~A ~A" + (lisp-implementation-type) + (lisp-implementation-version) + (software-type) + (machine-type) + (software-version)) + (let ((*package* (find-package :keyword))) + (pprint `(defsystem ,name-keyword + :class prebuilt-system + :components ((:compiled-file ,(pathname-name fasl))) + :lib ,(and library (file-namestring library))) + s))))) + +#-(or ecl mkcl) +(defmethod perform ((o fasl-op) (c system)) + (let* ((input-files (input-files o c)) + (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'string=)) + (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'string=)) + (output-files (output-files o c)) + (output-file (first output-files))) + (unless input-files (format t "WTF no input-files for ~S on ~S !???" o c)) + (when input-files + (assert output-files) + (when non-fasl-files + (error "On ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S" + (implementation-type) non-fasl-files)) + (when (and (typep o 'monolithic-bundle-op) + (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o))) + (error "prologue-code and epilogue-code are not supported on ~A" + (implementation-type))) + (with-staging-pathname (output-file) + (combine-fasls fasl-files output-file))))) + +(defmethod input-files ((o load-op) (s precompiled-system)) + (declare (ignorable o)) + (bundle-output-files (find-operation o 'fasl-op) s)) + +(defmethod component-depends-on ((o load-fasl-op) (s precompiled-system)) + (declare (ignorable o)) + `((load-op ,s) ,@(call-next-method))) + +#| ;; Example use: +(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl"))) +(asdf:load-system :precompiled-asdf-utils) +|# + +#+ecl +(defmethod perform ((o bundle-op) (c system)) + (let* ((object-files (input-files o c)) + (output (output-files o c)) + (bundle (first output)) + (kind (bundle-type o))) + (create-image + bundle (append object-files (bundle-op-lisp-files o)) + :kind kind + :entry-point (component-entry-point c) + :prologue-code + (when (typep o 'monolithic-bundle-op) + (monolithic-op-prologue-code o)) + :epilogue-code + (when (typep o 'monolithic-bundle-op) + (monolithic-op-epilogue-code o)) + :build-args (bundle-op-build-args o)))) + +#+mkcl (progn - (defun register-pre-built-system (name) - (register-system (make-instance 'system :name (coerce-name name) :source-file nil))) + (defmethod perform ((o lib-op) (s system)) + (apply #'compiler::build-static-library (first output) + :lisp-object-files (input-files o s) (bundle-op-build-args o))) + + (defmethod perform ((o fasl-op) (s system)) + (apply #'compiler::build-bundle (second output) + :lisp-object-files (input-files o s) (bundle-op-build-args o))) + + (defun* bundle-system (system &rest args &key force (verbose t) version &allow-other-keys) + (declare (ignore force verbose version)) + (apply #'operate 'binary-op system args))) - #+(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)))) +#+(or ecl mkcl) +(defun* register-pre-built-system (name) + (register-system (make-instance 'system :name (coerce-name name) :source-file nil))) +;;;; ------------------------------------------------------------------------- +;;;; Concatenate-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))))) +(asdf/package:define-package :asdf/concatenate-source + (:recycle :asdf/concatenate-source :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/component :asdf/operation + :asdf/system :asdf/find-system :asdf/defsystem + :asdf/action :asdf/lisp-action :asdf/bundle) + (:export + #:concatenate-source-op + #:load-concatenated-source-op + #:compile-concatenated-source-op + #:load-compiled-concatenated-source-op + #:monolithic-concatenate-source-op + #:monolithic-load-concatenated-source-op + #:monolithic-compile-concatenated-source-op + #:monolithic-load-compiled-concatenated-source-op + #:component-concatenated-source-file + #:concatenated-source-file)) +(in-package :asdf/concatenate-source) + +;;; +;;; Concatenate sources +;;; +(defclass concatenate-source-op (bundle-op) + ((bundle-type :initform "lisp"))) +(defclass load-concatenated-source-op (basic-load-op operation) + ((bundle-type :initform :no-output-file))) +(defclass compile-concatenated-source-op (basic-compile-op bundle-op) + ((bundle-type :initform :fasl))) +(defclass load-compiled-concatenated-source-op (basic-load-op operation) + ((bundle-type :initform :no-output-file))) + +(defclass monolithic-concatenate-source-op (concatenate-source-op monolithic-op) ()) +(defclass monolithic-load-concatenated-source-op (load-concatenated-source-op monolithic-op) ()) +(defclass monolithic-compile-concatenated-source-op (compile-concatenated-source-op monolithic-op) ()) +(defclass monolithic-load-compiled-concatenated-source-op (load-compiled-concatenated-source-op monolithic-op) ()) + +(defmethod input-files ((operation concatenate-source-op) (s system)) + (loop :with encoding = (or (component-encoding s) *default-encoding*) + :with other-encodings = '() + :with around-compile = (around-compile-hook s) + :with other-around-compile = '() + :for c :in (required-components + s :goal-operation 'compile-op + :keep-operation 'compile-op + :other-systems (operation-monolithic-p operation)) + :append + (when (typep c 'cl-source-file) + (let ((e (component-encoding c))) + (unless (equal e encoding) + (pushnew e other-encodings :test 'equal))) + (let ((a (around-compile-hook c))) + (unless (equal a around-compile) + (pushnew a other-around-compile :test 'equal))) + (input-files (make-operation 'compile-op) c)) :into inputs + :finally + (when other-encodings + (warn "~S uses encoding ~A but has sources that use these encodings: ~A" + operation encoding other-encodings)) + (when other-around-compile + (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A" + operation around-compile other-around-compile)) + (return inputs))) + +(defmethod input-files ((o load-concatenated-source-op) (s system)) + (direct-dependency-files o s)) +(defmethod input-files ((o compile-concatenated-source-op) (s system)) + (direct-dependency-files o s)) +(defmethod output-files ((o compile-concatenated-source-op) (s system)) + (let ((input (first (input-files o s)))) + (list (compile-file-pathname input)))) +(defmethod input-files ((o load-compiled-concatenated-source-op) (s system)) + (direct-dependency-files o s)) + +(defmethod perform ((o concatenate-source-op) (s system)) + (let ((inputs (input-files o s)) + (output (output-file o s))) + (concatenate-files inputs output))) +(defmethod perform ((o load-concatenated-source-op) (s system)) + (perform-lisp-load-source o s)) +(defmethod perform ((o compile-concatenated-source-op) (s system)) + (perform-lisp-compilation o s)) +(defmethod perform ((o load-compiled-concatenated-source-op) (s system)) + (perform-lisp-load-fasl o s)) + +(defmethod component-depends-on ((o concatenate-source-op) (s system)) + (declare (ignorable o s)) nil) +(defmethod component-depends-on ((o load-concatenated-source-op) (s system)) + (declare (ignorable o s)) `((prepare-op ,s) (concatenate-source-op ,s))) +(defmethod component-depends-on ((o compile-concatenated-source-op) (s system)) + (declare (ignorable o s)) `((concatenate-source-op ,s))) +(defmethod component-depends-on ((o load-compiled-concatenated-source-op) (s system)) + (declare (ignorable o s)) `((compile-concatenated-source-op ,s))) + +(defmethod component-depends-on ((o monolithic-concatenate-source-op) (s system)) + (declare (ignorable o s)) nil) +(defmethod component-depends-on ((o monolithic-load-concatenated-source-op) (s system)) + (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s))) +(defmethod component-depends-on ((o monolithic-compile-concatenated-source-op) (s system)) + (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s))) +(defmethod component-depends-on ((o monolithic-load-compiled-concatenated-source-op) (s system)) + (declare (ignorable o s)) `((monolithic-compile-concatenated-source-op ,s))) + +;;;; ------------------------------------------------------------------------- +;;; Backward-compatible interfaces + +(asdf/package:define-package :asdf/backward-interface + (:recycle :asdf/backward-interface :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/component :asdf/system :asdf/operation :asdf/action + :asdf/lisp-build :asdf/operate :asdf/output-translations) + (:export + #:*asdf-verbose* + #:operation-error #:compile-error #:compile-failed #:compile-warned + #:error-component #:error-operation + #:component-load-dependencies + #:enable-asdf-binary-locations-compatibility + #:operation-forced + #:operation-on-failure + #:operation-on-warnings + #:run-shell-command + #:system-definition-pathname)) +(in-package :asdf/backward-interface) + +(define-condition operation-error (error) ;; Bad, backward-compatible name + ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel + ((component :reader error-component :initarg :component) + (operation :reader error-operation :initarg :operation)) + (:report (lambda (c s) + (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>") + (type-of c) (error-operation c) (error-component c))))) +(define-condition compile-error (operation-error) ()) +(define-condition compile-failed (compile-error) ()) +(define-condition compile-warned (compile-error) ()) + +(defun* component-load-dependencies (component) + ;; Old deprecated name for the same thing. Please update your software. + (component-sibling-dependencies component)) + +(defgeneric* operation-forced (operation)) ;; Used by swank.asd for swank-loader. +(defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force)) + +(defgeneric* operation-on-warnings (operation)) +(defgeneric* operation-on-failure (operation)) +#-gcl2.6 (defgeneric* (setf operation-on-warnings) (x operation)) +#-gcl2.6 (defgeneric* (setf operation-on-failure) (x operation)) +(defmethod operation-on-warnings ((o operation)) + (declare (ignorable o)) *compile-file-warnings-behaviour*) +(defmethod operation-on-failure ((o operation)) + (declare (ignorable o)) *compile-file-failure-behaviour*) +(defmethod (setf operation-on-warnings) (x (o operation)) + (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x)) +(defmethod (setf operation-on-failure) (x (o operation)) + (declare (ignorable o)) (setf *compile-file-failure-behaviour* x)) + +(defun* system-definition-pathname (x) + ;; As of 2.014.8, we mean to make this function obsolete, + ;; but that won't happen until all clients have been updated. + ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead" + "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete. +It used to expose ASDF internals with subtle differences with respect to +user expectations, that have been refactored away since. +We recommend you use ASDF:SYSTEM-SOURCE-FILE instead +for a mostly compatible replacement that we're supporting, +or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME +if that's whay you mean." ;;) + (system-source-file x)) + + +;;;; ASDF-Binary-Locations compatibility + +(defun* enable-asdf-binary-locations-compatibility + (&key + (centralize-lisp-binaries nil) + (default-toplevel-directory + (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ??? + (include-per-user-information nil) + (map-all-source-files (or #+(or clisp ecl mkcl) t nil)) + (source-to-target-mappings nil)) + #+(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 CLISP, ECL and MKCL")) + (let* ((fasl-type (compile-file-type)) + (mapped-files (if map-all-source-files *wild-file* + (make-pathname :type fasl-type :defaults *wild-file*))) + (destination-directory + (if centralize-lisp-binaries + `(,default-toplevel-directory + ,@(when include-per-user-information + (cdr (pathname-directory (user-homedir)))) + :implementation ,*wild-inferiors*) + `(:root ,*wild-inferiors* :implementation)))) + (initialize-output-translations + `(:output-translations + , at source-to-target-mappings + #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) + #+abcl (#p"/___jar___file___root___/**/*.*" (, at destination-directory)) + ((:root ,*wild-inferiors* ,mapped-files) + (, at destination-directory ,mapped-files)) + (t t) + :ignore-inherited-configuration)))) + +(defmethod operate :before (operation-class system &rest args &key &allow-other-keys) + (declare (ignorable operation-class system args)) + (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil) + (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using. +ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS, +which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS, +and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details. +In case you insist on preserving your previous A-B-L configuration, but +do not know how to achieve the same effect with A-O-T, you may use function +ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual; +call that function where you would otherwise have loaded and configured A-B-L."))) + + +;;;; run-shell-command +;; +;; WARNING! The function below is dysfunctional and deprecated. +;; Please use asdf/run-program:run-program instead. +;; +(defun* run-shell-command (control-string &rest args) + "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and +synchronously execute the result using a Bourne-compatible shell, with +output to *VERBOSE-OUT*. Returns the shell's exit code. - (setf *compile-op-compile-file-function* 'compile-file-keeping-object) +PLEASE DO NOT USE. +Deprecated function, for backward-compatibility only. +Please use ASDF-DRIVER:RUN-PROGRAM instead." + (let ((command (apply 'format nil control-string args))) + (asdf-message "; $ ~A~%" command) + (run-program command :force-shell t :ignore-error-status t :output *verbose-out*))) +;;;; --------------------------------------------------------------------------- +;;;; Handle ASDF package upgrade, including implementation-dependent magic. - (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))))) +(asdf/package:define-package :asdf/interface + (:nicknames :asdf :asdf-utilities) + (:recycle :asdf/interface :asdf) + (:unintern + #:*asdf-revision* #:around #:asdf-method-combination + #:do-traverse #:do-dep #:do-one-dep #:visit-action #:component-visited-p + #:split #:make-collector + #:loaded-systems ; makes for annoying SLIME completion + #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/component :asdf/system :asdf/find-system :asdf/find-component + :asdf/operation :asdf/action :asdf/lisp-action + :asdf/output-translations :asdf/source-registry + :asdf/plan :asdf/operate :asdf/defsystem :asdf/bundle :asdf/concatenate-source + :asdf/backward-internals :asdf/backward-interface) + ;; TODO: automatically generate interface with reexport? + (:export + #:defsystem #:find-system #:locate-system #:coerce-name + #:oos #:operate #:traverse #:perform-plan + #:system-definition-pathname #:with-system-definitions + #:search-for-system-definition #:find-component #:component-find-path + #:compile-system #:load-system #:load-systems + #:require-system #:test-system #:clear-system + #:operation #:upward-operation #:downward-operation #:make-operation + #:build-system #:build-op + #:load-op #:prepare-op #:compile-op + #:prepare-source-op #:load-source-op #:test-op + #:feature #:version #:version-satisfies #:upgrade-asdf + #:implementation-identifier #:implementation-type #:hostname + #:input-files #:output-files #:output-file #:perform + #:operation-done-p #:explain #:component-sibling-dependencies + #:needed-in-image-p + ;; #:run-program ; we can't export it, because SB-GROVEL :use's both ASDF and SB-EXT. + #:component-load-dependencies #:run-shell-command ; deprecated, do not use + #:bundle-op #:precompiled-system #:compiled-file #:bundle-system + #+ecl #:make-build + #:program-op #:load-fasl-op #:fasl-op #:lib-op #:binary-op + #:concatenate-source-op + #:load-concatenated-source-op + #:compile-concatenated-source-op + #:load-compiled-concatenated-source-op + #:monolithic-concatenate-source-op + #:monolithic-load-concatenated-source-op + #:monolithic-compile-concatenated-source-op + #:monolithic-load-compiled-concatenated-source-op + #:operation-monolithic-p + + #:component #:parent-component #:child-component #:system #:module + #:file-component #:source-file #:c-source-file #:java-source-file + #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp + #:static-file #:doc-file #:html-file :text-file + #:source-file-type + + #:component-children ; component accessors + #:component-children-by-name + #:component-pathname + #:component-relative-pathname + #:component-name + #:component-version + #:component-parent + #:component-property + #:component-system + #:component-encoding + #:component-external-format + + #:component-depends-on ; backward-compatible name rather than action-depends-on + #:module-components ; backward-compatibility + #:operation-on-warnings #:operation-on-failure ; backward-compatibility + + #:system-description + #:system-long-description + #:system-author + #:system-maintainer + #:system-license + #:system-licence + #:system-source-file + #:system-source-directory + #:system-relative-pathname + #:map-systems + + #:operation-description + + #:*system-definition-search-functions* ; variables + #:*central-registry* + #:*compile-file-warnings-behaviour* + #:*compile-file-failure-behaviour* + #:*resolve-symlinks* + #:*load-system-operation* + #:*asdf-verbose* + #:*verbose-out* + + #:asdf-version + + #:operation-error #:compile-failed #:compile-warned #:compile-error + #:error-name + #:error-pathname + #:load-system-definition-error + #:error-component #:error-operation + #:system-definition-error + #:missing-component + #:missing-component-of-version + #:missing-dependency + #:missing-dependency-of-version + #:circular-dependency ; errors + #:duplicate-names + + #:try-recompiling + #:retry + #:accept ; restarts + #:coerce-entry-to-directory + #:remove-entry-from-registry + + #:*encoding-detection-hook* + #:*encoding-external-format-hook* + #:*default-encoding* + #:*utf-8-external-format* + + #:clear-configuration + #:*output-translations-parameter* + #:initialize-output-translations + #:disable-output-translations + #:clear-output-translations + #:ensure-output-translations + #:apply-output-translations + #:compile-file* + #:compile-file-pathname* + #:enable-asdf-binary-locations-compatibility + #:*default-source-registries* + #:*source-registry-parameter* + #:initialize-source-registry + #:compute-source-registry + #:clear-source-registry + #:ensure-source-registry + #:process-source-registry + #:system-registered-p #:registered-systems #:already-loaded-systems + #:resolve-location + #:asdf-message + #:user-output-translations-pathname + #:system-output-translations-pathname + #:user-output-translations-directory-pathname + #:system-output-translations-directory-pathname + #:user-source-registry + #:system-source-registry + #:user-source-registry-directory + #:system-source-registry-directory)) ;;;; ----------------------------------------------------------------------- -;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL -;;;; -(defun* module-provide-asdf (name) - (handler-bind - ((style-warning #'muffle-warning) - #-genera - (missing-component (constantly nil)) - (error #'(lambda (e) - (format *error-output* (compatfmt "~@~%") - name e)))) - (let ((*verbose-out* (make-broadcast-stream)) - (system (find-system (string-downcase name) nil))) - (when system - (require-system system :verbose nil) - t)))) +;;;; ASDF Footer: last words and cleanup + +(asdf/package:define-package :asdf/footer + (:recycle :asdf/footer :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action + :asdf/operate :asdf/bundle :asdf/concatenate-source + :asdf/output-translations :asdf/source-registry + :asdf/backward-internals :asdf/defsystem :asdf/backward-interface)) +(in-package :asdf/footer) + +;;;; Configure +(setf asdf/utility:*asdf-debug-utility* + '(asdf/system:system-relative-pathname :asdf "contrib/debug.lisp")) + +;;;; Hook ASDF into the implementation's REQUIRE and other entry points. #+(or abcl clisp clozure cmu ecl mkcl sbcl) -(let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom)))) +(let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil)))) (when x (eval `(pushnew 'module-provide-asdf #+abcl sys::*module-provider-functions* @@ -4487,45 +8787,48 @@ #+mkcl mk-ext:*module-provider-functions* #+sbcl sb-ext:*module-provider-functions*)))) +#+(or ecl mkcl) +(progn + (pushnew '("fasb" . si::load-binary) si:*load-hooks* :test 'equal :key 'car) -;;;; ------------------------------------------------------------------------- -;;;; Cleanups after hot-upgrade. -;;;; Things to do in case we're upgrading from a previous version of ASDF. -;;;; See https://bugs.launchpad.net/asdf/+bug/485687 -;;;; + #+(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)))))) -;;; If a previous version of ASDF failed to read some configuration, try again. + +;;;; Cleanups after hot-upgrade. +;; Things to do in case we're upgrading from a previous version of ASDF. +;; See https://bugs.launchpad.net/asdf/+bug/485687 +;; +;; If a previous version of ASDF failed to read some configuration, try again. (when *ignored-configuration-form* (clear-configuration) (setf *ignored-configuration-form* nil)) -;;;; ----------------------------------------------------------------- ;;;; Done! -(when *load-verbose* - (asdf-message ";; ASDF, version ~a~%" (asdf-version))) - -#+mkcl -(handler-case - (progn - (load-sysdef "asdf-bundle" - (subpathname (translate-logical-pathname #P"CONTRIB:") - "asdf-bundle/asdf-bundle.asd")) - (load-system "asdf-bundle")) - (error (e) - (format *error-output* - "~&;;; ASDF: Failed to load package 'asdf-bundle'!~%;;; ~A~%" - e))) #+allegro (eval-when (:compile-toplevel :execute) (when (boundp 'excl:*warn-on-nested-reader-conditionals*) - (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*))) + (setf excl:*warn-on-nested-reader-conditionals* asdf/common-lisp::*acl-warn-save*))) -(pushnew :asdf *features*) -(pushnew :asdf2 *features*) +(dolist (f '(:asdf :asdf2 :asdf2.27)) (pushnew f *features*)) (provide :asdf) +(when *load-verbose* + (asdf-message ";; ASDF, version ~a~%" (asdf-version))) + + ;;; Local Variables: ;;; mode: lisp ;;; End: From mevenson at common-lisp.net Mon Jan 28 13:24:59 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 28 Jan 2013 05:24:59 -0800 Subject: [armedbear-cvs] r14362 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Jan 28 05:24:57 2013 New Revision: 14362 Log: asdf-2.26.158.1: current asdf plus ABCL conditional for SETF DOCUMENTATION bug. 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 Sun Jan 27 01:47:48 2013 (r14361) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Mon Jan 28 05:24:57 2013 (r14362) @@ -1,5 +1,5 @@ -;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.26.143.1: Another System Definition Facility. +;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- +;;; This is ASDF 2.26.158.1: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . @@ -60,7 +60,7 @@ #+(or abcl clisp cmu) (eval-when (:load-toplevel :compile-toplevel :execute) - (unless (member :asdf2.27 *features*) + (unless (member :asdf3 *features*) (let* ((existing-version (when (find-package :asdf) (or (symbol-value (find-symbol (string :*asdf-version*) :asdf)) @@ -81,7 +81,7 @@ ;; See https://bugs.launchpad.net/asdf/+bug/485687 ;; ;; CAUTION: we must handle the first few packages specially for hot-upgrade. -;; asdf/package will be frozen as of 2.27 +;; asdf/package will be frozen as of ASDF 3 ;; to forever export the same exact symbols. ;; Any other symbol must be import-from'ed ;; and reexported in a different package @@ -422,7 +422,7 @@ import-from export intern recycle mix reexport unintern) - (declare (ignorable documentation)) + #+(or gcl2.6 genera) (declare (ignore documentation)) (macrolet ((when-fishy (&body body) `(when-package-fishiness , at body)) (fishy (&rest info) `(note-package-fishiness , at info))) (let* ((package-name (string name)) @@ -591,7 +591,8 @@ t))))) (when (and accessible (eq ustat :external)) (ensure-exported name sym u))))))) - #-(or gcl genera) (setf (documentation package t) documentation) #+gcl documentation + #-(or gcl2.6 genera) + (when documentation (setf (documentation package t) documentation)) (loop :for p :in (set-difference (package-use-list package) (append mix use)) :do (fishy :use (package-names p)) (unuse-package p package)) (loop :for p :in discarded @@ -707,7 +708,6 @@ (setf excl::*autoload-package-name-alist* (remove "asdf" excl::*autoload-package-name-alist* :test 'equalp :key 'car)) - #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, ;; but can run ASDF 2.011. GCL 2.6 has even more issues. @@ -736,6 +736,7 @@ (:reexport :common-lisp) (:recycle :asdf/common-lisp :asdf) #+allegro (:intern #:*acl-warn-save*) + #+cormanlisp (:shadow #:user-homedir-pathname) #+cormanlisp (:export #:logical-pathname #:translate-logical-pathname @@ -774,6 +775,9 @@ (deftype logical-pathname () nil) (defun make-broadcast-stream () *error-output*) (defun translate-logical-pathname (x) x) + (defun user-homedir-pathname (&optional host) + (declare (ignore host)) + (parse-namestring (format nil "~A\\" (cl:user-homedir-pathname)))) (defun file-namestring (p) (setf p (pathname p)) (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) @@ -857,26 +861,43 @@ (setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict ANSI class redefinition semantics -;;;; compatfmt: avoid fancy format directives when unsupported - +;;;; Looping (defmacro loop* (&rest rest) #-genera `(loop , at rest) #+genera `(lisp:loop , at rest)) ;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh. + +;;;; compatfmt: avoid fancy format directives when unsupported (eval-when (:load-toplevel :compile-toplevel :execute) - (defun strcat (&rest strings) - (apply 'concatenate 'string strings))) + (defun remove-substrings (substrings string) + (let ((length (length string)) (stream nil)) + (labels ((emit (start end) + (when (and (zerop start) (= end length)) + (return-from remove-substrings string)) + (unless stream (setf stream (make-string-output-stream))) + (write-string string stream :start start :end end)) + (recurse (substrings start end) + (cond + ((= start end)) + ((null substrings) (emit start end)) + (t (let* ((sub (first substrings)) + (found (search sub string)) + (more (rest substrings))) + (cond + (found + (recurse more start found) + (recurse more (+ found (length sub)) end)) + (t + (recurse more start end)))))))) + (recurse substrings 0 length)) + (if stream (get-output-stream-string stream) "")))) (defmacro compatfmt (format) #+(or gcl genera) - (loop* :for (unsupported . replacement) - :in (append - '(("~3i~_" . "")) - #+(or genera gcl2.6) '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do - (loop :for found = (search unsupported format) :while found :do - (setf format (strcat (subseq format 0 found) replacement - (subseq format (+ found (length unsupported))))))) - format) + (remove-substrings `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")) format) + #-(or gcl genera) format) + + ;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities for ASDF @@ -884,9 +905,9 @@ (:recycle :asdf/utility :asdf) (:use :asdf/common-lisp :asdf/package) ;; import and reexport a few things defined in :asdf/common-lisp - (:import-from :asdf/common-lisp #:strcat #:compatfmt #:loop* + (:import-from :asdf/common-lisp #:compatfmt #:loop* #:remove-substrings #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix) - (:export #:nil #:strcat #:compatfmt #:loop* + (:export #:compatfmt #:loop* #:remove-substrings #:compatfmt #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix) (:export ;; magic helper to define debugging functions: @@ -895,7 +916,7 @@ #:if-let ;; basic flow control #:while-collecting #:appendf #:length=n-p #:remove-plist-keys #:remove-plist-key ;; lists and plists #:emptyp ;; sequences - #:first-char #:last-char #:split-string ;; strings + #:strcat #:first-char #:last-char #:split-string ;; strings #:string-prefix-p #:string-enclosed-p #:string-suffix-p #:find-class* ;; CLOS #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps @@ -958,7 +979,9 @@ ;;; Magic debugging help. See contrib/debug.lisp (defvar *asdf-debug-utility* - '(ignore-errors (merge-pathnames "cl/asdf/contrib/debug.lisp" (user-homedir-pathname))) + '(or (ignore-errors + (symbol-call :asdf :system-relative-pathname :asdf-driver "contrib/debug.lisp")) + (merge-pathnames "cl/asdf/contrib/debug.lisp" (user-homedir-pathname))) "form that evaluates to the pathname to your favorite debugging utilities") (defmacro asdf-debug (&rest keys) @@ -1040,6 +1063,8 @@ ;;; Strings +(defun* strcat (&rest strings) + (apply 'concatenate 'string strings)) (defun* first-char (s) (and (stringp s) (plusp (length s)) (char s 0))) @@ -1281,225 +1306,474 @@ (defmacro with-muffled-uninteresting-conditions ((conditions) &body body) `(call-with-muffled-uninteresting-conditions #'(lambda () , at body) ,conditions)) -;;;; ------------------------------------------------------------------------- -;;;; Portability layer around Common Lisp pathnames -(asdf/package:define-package :asdf/pathname - (:recycle :asdf/pathname :asdf) +;;;; --------------------------------------------------------------------------- +;;;; Access to the Operating System + +(asdf/package:define-package :asdf/os + (:recycle :asdf/os :asdf) (:use :asdf/common-lisp :asdf/package :asdf/utility) (:export - #:*resolve-symlinks* - ;; Making and merging pathnames, portably - #:normalize-pathname-directory-component #:denormalize-pathname-directory-component - #:pathname-equal - #:merge-pathname-directory-components #:make-pathname* #:*unspecific-pathname-type* - #:make-pathname-component-logical #:make-pathname-logical - #:merge-pathnames* - ;; Directories - #:pathname-directory-pathname #:pathname-parent-directory-pathname - #:directory-pathname-p #:ensure-directory-pathname #:file-pathname-p - ;; Absolute vs relative pathnames - #:ensure-pathname-absolute - #:relativize-directory-component #:relativize-pathname-directory - ;; Parsing filenames and lists thereof - #:component-name-to-pathname-components - #:split-name-type #:parse-unix-namestring #:unix-namestring - #:split-unix-namestring-directory-components - #:subpathname #:subpathname* #:subpathp - ;; Resolving symlinks somewhat - #:truenamize #:resolve-symlinks #:resolve-symlinks* - ;; Wildcard pathnames - #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden - ;; Pathname host and its root - #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p - #:pathname-root #:directory-separator-for-host - #:directorize-pathname-host-device - ;; defaults - #:nil-pathname #:with-pathname-defaults - ;; probe filesystem - #:truename* #:probe-file* #:safe-file-write-date - #:subdirectories #:directory-files #:directory* - #:filter-logical-directory-results #:collect-sub*directories - ;; Simple filesystem operations - #:ensure-all-directories-exist - #:rename-file-overwriting-target - #:delete-file-if-exists - ;; Translate a pathname - #:translate-pathname* - ;; temporary - #:add-pathname-suffix #:tmpize-pathname - #:call-with-staging-pathname #:with-staging-pathname - ;; physical pathnames - #:logical-pathname-p #:physical-pathname-p #:sane-physical-pathname #:root-pathname + #:featurep #:os-unix-p #:os-windows-p #:os-genera-p #:detect-os ;; features + #:getenv #:getenvp ;; environment variables + #:implementation-identifier ;; implementation identifier + #:implementation-type #:*implementation-type* + #:operating-system #:architecture #:lisp-version-string + #:hostname #:getcwd #:chdir ;; Windows shortcut support #:read-null-terminated-string #:read-little-endian - #:parse-file-location-info #:parse-windows-shortcut - ;; Checking constraints - #:ensure-pathname - #:absolutize-pathnames - ;; Output translations - #:*output-translation-function*)) + #:parse-file-location-info #:parse-windows-shortcut)) +(in-package :asdf/os) -(in-package :asdf/pathname) +;;; Features +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun* featurep (x &optional (*features* *features*)) + (cond + ((atom x) (and (member x *features*) t)) + ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x)))) + ((eq :or (car x)) (some #'featurep (cdr x))) + ((eq :and (car x)) (every #'featurep (cdr x))) + (t (error "Malformed feature specification ~S" x)))) -;;; User-visible parameters -(defvar *resolve-symlinks* t - "Determine whether or not ASDF resolves symlinks when defining systems. + (defun* os-unix-p () + (or #+abcl (featurep :unix) + #+(and (not abcl) (or unix cygwin darwin)) t)) -Defaults to T.") + (defun* os-windows-p () + (or #+abcl (featurep :windows) + #+(and (not (or unix cygwin darwin)) (or win32 windows mswindows mingw32)) t)) + (defun* os-genera-p () + (or #+genera t)) -;;; Normalizing pathnames across implementations + (defun* detect-os () + (flet ((yes (yes) (pushnew yes *features*)) + (no (no) (setf *features* (remove no *features*)))) + (cond + ((os-unix-p) (yes :os-unix) (no :os-windows) (no :genera)) + ((os-windows-p) (yes :os-windows) (no :os-unix) (no :genera)) + ((os-genera-p) (no :os-unix) (no :os-windows) (yes :genera)) + (t (error "Congratulations for trying XCVB on an operating system~%~ +that is neither Unix, nor Windows, nor even Genera.~%Now you port it."))))) -(defun* normalize-pathname-directory-component (directory) - "Given a pathname directory component, return an equivalent form that is a list" - #+gcl2.6 (setf directory (substitute :back :parent directory)) - (cond - #-(or cmu sbcl scl) ;; these implementations already normalize directory components. - ((stringp directory) `(:absolute ,directory)) - #+gcl2.6 - ((and (consp directory) (eq :root (first directory))) - `(:absolute ,@(rest directory))) - ((or (null directory) - (and (consp directory) (member (first directory) '(:absolute :relative)))) - directory) - #+gcl2.6 - ((consp directory) - `(:relative , at directory)) - (t - (error (compatfmt "~@") directory)))) + (detect-os)) -(defun* denormalize-pathname-directory-component (directory-component) - #-gcl2.6 directory-component - #+gcl2.6 - (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back))) - directory-component))) - (cond - ((and (consp d) (eq :relative (first d))) (rest d)) - ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d))) - (t d)))) +;;;; Environment variables: getting them, and parsing them. -(defun* merge-pathname-directory-components (specified defaults) - ;; Helper for merge-pathnames* that handles directory components. - (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* getenv (x) + (declare (ignorable x)) + #+(or abcl clisp ecl xcl) (ext:getenv x) + #+allegro (sys:getenv x) + #+clozure (ccl:getenv x) + #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=)) + #+cormanlisp + (let* ((buffer (ct:malloc 1)) + (cname (ct:lisp-string-to-c-string x)) + (needed-size (win:getenvironmentvariable cname buffer 0)) + (buffer1 (ct:malloc (1+ needed-size)))) + (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size)) + nil + (ct:c-string-to-lisp-string buffer1)) + (ct:free buffer) + (ct:free buffer1))) + #+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)))) + #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x) + #+sbcl (sb-ext:posix-getenv x) + #-(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)) -;; Giving :unspecific as :type argument to make-pathname is not portable. -;; See CLHS make-pathname and 19.2.2.2.3. -;; This will be :unspecific if supported, or NIL if not. -(defparameter *unspecific-pathname-type* - #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific - #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil) +(defun* getenvp (x) + "Predicate that is true if the named variable is present in the libc environment, +then returning the non-empty string value of the variable" + (let ((g (getenv x))) (and (not (emptyp g)) g))) -(defun* make-pathname* (&rest keys &key (directory nil directoryp) - host (device () devicep) name type version defaults - #+scl &allow-other-keys) - "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and - tries hard to make a pathname that will actually behave as documented, - despite the peculiarities of each implementation" - (declare (ignorable host device devicep name type version defaults)) - (apply 'make-pathname - (append - #+allegro (when (and devicep (null device)) `(:device :unspecific)) - (when directoryp - `(:directory ,(denormalize-pathname-directory-component directory))) - keys))) -(defun* make-pathname-component-logical (x) - "Make a pathname component suitable for use in a logical-pathname" - (typecase x - ((eql :unspecific) nil) - #+clisp (string (string-upcase x)) - #+clisp (cons (mapcar 'make-pathname-component-logical x)) - (t x))) +;;;; implementation-identifier +;; +;; produce a string to identify current implementation. +;; Initially stolen from SLIME's SWANK, completely rewritten since. +;; We're back to runtime checking, for the sake of e.g. ABCL. -(defun* make-pathname-logical (pathname host) - "Take a PATHNAME's directory, name, type and version components, -and make a new pathname with corresponding components and specified logical HOST" - (make-pathname* - :host host - :directory (make-pathname-component-logical (pathname-directory pathname)) - :name (make-pathname-component-logical (pathname-name pathname)) - :type (make-pathname-component-logical (pathname-type pathname)) - :version (make-pathname-component-logical (pathname-version pathname)))) +(defun* first-feature (feature-sets) + (dolist (x feature-sets) + (multiple-value-bind (short long feature-expr) + (if (consp x) + (values (first x) (second x) (cons :or (rest x))) + (values x x x)) + (when (featurep feature-expr) + (return (values short long)))))) +(defun* implementation-type () + (first-feature + '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) + (:cmu :cmucl :cmu) :ecl :gcl + (:lwpe :lispworks-personal-edition) (:lw :lispworks) + :mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl))) -;;; Some pathname predicates +(defvar *implementation-type* (implementation-type)) -(defun* pathname-equal (p1 p2) - (when (stringp p1) (setf p1 (pathname p1))) - (when (stringp p2) (setf p2 (pathname p2))) - (flet ((normalize-component (x) - (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal) - x))) - (macrolet ((=? (&rest accessors) - (flet ((frob (x) - (reduce 'list (cons 'normalize-component accessors) - :initial-value x :from-end t))) - `(equal ,(frob 'p1) ,(frob 'p2))))) - (or (and (null p1) (null p2)) - (and (pathnamep p1) (pathnamep p2) - (and (=? pathname-host) - (=? pathname-device) - (=? normalize-pathname-directory-component pathname-directory) - (=? pathname-name) - (=? pathname-type) - (=? pathname-version))))))) +(defun* operating-system () + (first-feature + '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! + (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd + (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd + (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix + :genera))) -(defun* logical-pathname-p (x) - (typep x 'logical-pathname)) +(defun* architecture () + (first-feature + '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386)) + (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target) + (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc) + :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc) + :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach + ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI, + ;; we may have to segregate the code still by architecture. + (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))) -(defun* physical-pathname-p (x) - (and (pathnamep x) (not (logical-pathname-p x)))) +#+clozure +(defun* ccl-fasl-version () + ;; the fasl version is target-dependent from CCL 1.8 on. + (or (let ((s 'ccl::target-fasl-version)) + (and (fboundp s) (funcall s))) + (and (boundp 'ccl::fasl-version) + (symbol-value 'ccl::fasl-version)) + (error "Can't determine fasl version."))) -(defun* absolute-pathname-p (pathspec) - "If PATHSPEC is a pathname or namestring object that parses as a pathname -possessing an :ABSOLUTE directory component, return the (parsed) pathname. -Otherwise return NIL" - (and pathspec - (typep pathspec '(or null pathname string)) - (let ((pathname (pathname pathspec))) - (and (eq :absolute (car (normalize-pathname-directory-component - (pathname-directory pathname)))) - pathname)))) +(defun* lisp-version-string () + (let ((s (lisp-implementation-version))) + (car ; as opposed to OR, this idiom prevents some unreachable code warning + (list + #+allegro + (format nil "~A~@[~A~]~@[~A~]~@[~A~]" + excl::*common-lisp-version-number* + ;; 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")) + (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.) + #+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) + #+scl (format nil "~A~A" s + ;; ANSI upper case vs lower case. + (ecase ext:*case-mode* (:upper "") (:lower "l"))) + #+ecl (format nil "~A~@[-~A~]" s + (let ((vcs-id (ext:lisp-implementation-vcs-id))) + (subseq vcs-id 0 (min (length vcs-id) 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)) + #+mcl (subseq s 8) ; strip the leading "Version " + s)))) -(defun* relative-pathname-p (pathspec) - "If PATHSPEC is a pathname or namestring object that parses as a pathname -possessing a :RELATIVE or NIL directory component, return the (parsed) pathname. -Otherwise return NIL" - (and pathspec - (typep pathspec '(or null pathname string)) - (let* ((pathname (pathname pathspec)) - (directory (normalize-pathname-directory-component - (pathname-directory pathname)))) - (when (or (null directory) (eq :relative (car directory))) - pathname)))) +(defun* implementation-identifier () + (substitute-if + #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\"")) + (format nil "~(~a~@{~@[-~a~]~}~)" + (or (implementation-type) (lisp-implementation-type)) + (or (lisp-version-string) (lisp-implementation-version)) + (or (operating-system) (software-type)) + (or (architecture) (machine-type))))) + + +;;;; Other system information + +(defun* hostname () + ;; Note: untested on RMCL + #+(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 (symbol-call :excl.osi :gethostname) + #+clisp (first (split-string (machine-instance) :separator " ")) + #+gcl (system:gethostname)) -(defun* hidden-pathname-p (pathname) - "Return a boolean that is true if the pathname is hidden as per Unix style, -i.e. its name starts with a dot." - (and pathname (equal (first-char (pathname-name pathname)) #\.))) +;;; Current directory + +(defun* getcwd () + "Get the current working directory as per POSIX getcwd(3), as a pathname object" + (or #+abcl (parse-namestring + (java:jstatic "getProperty" "java.lang.System" "user.dir") :ensure-directory t) + #+allegro (excl::current-directory) + #+clisp (ext:default-directory) + #+clozure (ccl:current-directory) + #+(or cmu scl) (ext:parse-unix-namestring + (nth-value 1 (unix:unix-current-directory)) :ensure-directory t) + #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return? + #+ecl (ext:getcwd) + #+gcl (parse-namestring ;; this is a joke. Isn't there a better way? + (first (symbol-call :asdf/driver :run-program '("/bin/pwd") :output :lines))) + #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical! + #+lispworks (system:current-directory) + #+mkcl (mk-ext:getcwd) + #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/)) + #+xcl (extensions:current-directory) + (error "getcwd not supported on your implementation"))) + +(defun* chdir (x) + "Change current directory, as per POSIX chdir(2)" + (declare (ignorable x)) + (or #+abcl (java:jstatic "setProperty" "java.lang.System" "user.dir" (namestring x)) + #+allegro (excl:chdir x) + #+clisp (ext:cd x) + #+clozure (setf (ccl:current-directory) x) + #+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x)) + #+cormanlisp (unless (zerop (win32::_chdir (namestring x))) + (error "Could not set current directory to ~A" x)) + #+ecl (ext:chdir x) + #+genera (setf *default-pathname-defaults* (pathname x)) + #+lispworks (hcl:change-directory x) + #+mkcl (mk-ext:chdir x) + #+sbcl (symbol-call :sb-posix :chdir (sb-ext:native-namestring x)) + (error "chdir not supported on your implementation"))) + + +;;;; ----------------------------------------------------------------- +;;;; Windows shortcut support. Based on: +;;;; +;;;; Jesse Hager: The Windows Shortcut File Format. +;;;; http://www.wotsit.org/list.asp?fc=13 + +#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera. +(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)) + +(defun* read-null-terminated-string (s) + (with-output-to-string (out) + (loop :for code = (read-byte s) + :until (zerop code) + :do (write-char (code-char code) out)))) + +(defun* read-little-endian (s &optional (bytes 4)) + (loop :for i :from 0 :below bytes + :sum (ash (read-byte s) (* 8 i)))) + +(defun* parse-file-location-info (s) + (let ((start (file-position s)) + (total-length (read-little-endian s)) + (end-of-header (read-little-endian s)) + (fli-flags (read-little-endian s)) + (local-volume-offset (read-little-endian s)) + (local-offset (read-little-endian s)) + (network-volume-offset (read-little-endian s)) + (remaining-offset (read-little-endian s))) + (declare (ignore total-length end-of-header local-volume-offset)) + (unless (zerop fli-flags) + (cond + ((logbitp 0 fli-flags) + (file-position s (+ start local-offset))) + ((logbitp 1 fli-flags) + (file-position s (+ start + network-volume-offset + #x14)))) + (strcat (read-null-terminated-string s) + (progn + (file-position s (+ start remaining-offset)) + (read-null-terminated-string s)))))) + +(defun* parse-windows-shortcut (pathname) + (with-open-file (s pathname :element-type '(unsigned-byte 8)) + (handler-case + (when (and (= (read-little-endian s) *link-initial-dword*) + (let ((header (make-array (length *link-guid*)))) + (read-sequence header s) + (equalp header *link-guid*))) + (let ((flags (read-little-endian s))) + (file-position s 76) ;skip rest of header + (when (logbitp 0 flags) + ;; skip shell item id list + (let ((length (read-little-endian s 2))) + (file-position s (+ length (file-position s))))) + (cond + ((logbitp 1 flags) + (parse-file-location-info s)) + (t + (when (logbitp 2 flags) + ;; skip description string + (let ((length (read-little-endian s 2))) + (file-position s (+ length (file-position s))))) + (when (logbitp 3 flags) + ;; finally, our pathname + (let* ((length (read-little-endian s 2)) + (buffer (make-array length))) + (read-sequence buffer s) + (map 'string #'code-char buffer))))))) + (end-of-file (c) + (declare (ignore c)) + nil))))) + + +;;;; ------------------------------------------------------------------------- +;;;; Portability layer around Common Lisp pathnames + +(asdf/package:define-package :asdf/pathname + (:recycle :asdf/pathname :asdf) + (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os) + (:export + #:*resolve-symlinks* + ;; Making pathnames, portably + #:normalize-pathname-directory-component #:denormalize-pathname-directory-component + #:merge-pathname-directory-components #:*unspecific-pathname-type* #:make-pathname* + #:make-pathname-component-logical #:make-pathname-logical + #:merge-pathnames* + ;; Predicates + #:pathname-equal #:logical-pathname-p #:physical-pathname-p + #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-pathname-p + ;; Directories + #:pathname-directory-pathname #:pathname-parent-directory-pathname + #:directory-pathname-p #:ensure-directory-pathname + ;; defaults + #:nil-pathname #:with-pathname-defaults #:*nil-pathname* + ;; Parsing filenames + #:component-name-to-pathname-components + #:split-name-type #:parse-unix-namestring #:unix-namestring + #:split-unix-namestring-directory-components + #:native-namestring #:parse-native-namestring + #:subpathname #:subpathname* + ;; Wildcard pathnames + #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden + ;; probe filesystem + #:truename* #:safe-file-write-date #:probe-file* + #:directory* #:filter-logical-directory-results #:directory-files #:subdirectories + #:collect-sub*directories + ;; Absolute vs relative pathnames + #:ensure-pathname-absolute + #:pathname-root #:pathname-host-pathname + #:subpathp + ;; Resolving symlinks somewhat + #:truenamize #:resolve-symlinks #:resolve-symlinks* + ;; Checking constraints + #:ensure-pathname + ;; merging with cwd + #:get-pathname-defaults #:call-with-current-directory #:with-current-directory + ;; Environment pathnames + #:inter-directory-separator #:split-native-pathnames-string + #:getenv-pathname #:getenv-pathnames + #:getenv-absolute-directory #:getenv-absolute-directories + #:lisp-implementation-directory #:lisp-implementation-pathname-p + ;; Translate a pathname + #:relativize-directory-component #:relativize-pathname-directory + #:directory-separator-for-host #:directorize-pathname-host-device + #:translate-pathname* + #:*output-translation-function*)) + +(in-package :asdf/pathname) + +;;; User-visible parameters +(defvar *resolve-symlinks* t + "Determine whether or not ASDF resolves symlinks when defining systems. + +Defaults to T.") + + +;;; Normalizing pathnames across implementations + +(defun* normalize-pathname-directory-component (directory) + "Given a pathname directory component, return an equivalent form that is a list" + #+gcl2.6 (setf directory (substitute :back :parent directory)) + (cond + #-(or cmu sbcl scl) ;; these implementations already normalize directory components. + ((stringp directory) `(:absolute ,directory)) + #+gcl2.6 + ((and (consp directory) (eq :root (first directory))) + `(:absolute ,@(rest directory))) + ((or (null directory) + (and (consp directory) (member (first directory) '(:absolute :relative)))) + directory) + #+gcl2.6 + ((consp directory) + `(:relative , at directory)) + (t + (error (compatfmt "~@") directory)))) + +(defun* denormalize-pathname-directory-component (directory-component) + #-gcl2.6 directory-component + #+gcl2.6 + (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back))) + directory-component))) + (cond + ((and (consp d) (eq :relative (first d))) (rest d)) + ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d))) + (t d)))) + +(defun* merge-pathname-directory-components (specified defaults) + ;; Helper for merge-pathnames* that handles directory components. + (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))))))))))) + +;; Giving :unspecific as :type argument to make-pathname is not portable. +;; See CLHS make-pathname and 19.2.2.2.3. +;; This will be :unspecific if supported, or NIL if not. +(defparameter *unspecific-pathname-type* + #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific + #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil) + +(defun* make-pathname* (&rest keys &key (directory nil #+gcl2.6 directoryp) + host (device () #+allegro devicep) name type version defaults + #+scl &allow-other-keys) + "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and + tries hard to make a pathname that will actually behave as documented, + despite the peculiarities of each implementation" + (declare (ignorable host device directory name type version defaults)) + (apply 'make-pathname + (append + #+allegro (when (and devicep (null device)) `(:device :unspecific)) + #+gcl2.6 + (when directoryp + `(:directory ,(denormalize-pathname-directory-component directory))) + keys))) + +(defun* make-pathname-component-logical (x) + "Make a pathname component suitable for use in a logical-pathname" + (typecase x + ((eql :unspecific) nil) + #+clisp (string (string-upcase x)) + #+clisp (cons (mapcar 'make-pathname-component-logical x)) + (t x))) + +(defun* make-pathname-logical (pathname host) + "Take a PATHNAME's directory, name, type and version components, +and make a new pathname with corresponding components and specified logical HOST" + (make-pathname* + :host host + :directory (make-pathname-component-logical (pathname-directory pathname)) + :name (make-pathname-component-logical (pathname-name pathname)) + :type (make-pathname-component-logical (pathname-type pathname)) + :version (make-pathname-component-logical (pathname-version pathname)))) -;;;; merging pathnames (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, @@ -1523,7 +1797,7 @@ (type (or (pathname-type specified) (pathname-type defaults))) (version (or (pathname-version specified) (pathname-version defaults)))) (labels ((unspecific-handler (p) - (if (logical-pathname-p p) #'make-pathname-component-logical #'identity))) + (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity))) (multiple-value-bind (host device directory unspecific-handler) (ecase (first directory) ((:absolute) @@ -1541,7 +1815,80 @@ :type (funcall unspecific-handler type) :version (funcall unspecific-handler version)))))) -;;; Directories + +;;; Some pathname predicates + +(defun* pathname-equal (p1 p2) + (when (stringp p1) (setf p1 (pathname p1))) + (when (stringp p2) (setf p2 (pathname p2))) + (flet ((normalize-component (x) + (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal) + x))) + (macrolet ((=? (&rest accessors) + (flet ((frob (x) + (reduce 'list (cons 'normalize-component accessors) + :initial-value x :from-end t))) + `(equal ,(frob 'p1) ,(frob 'p2))))) + (or (and (null p1) (null p2)) + (and (pathnamep p1) (pathnamep p2) + (and (=? pathname-host) + (=? pathname-device) + (=? normalize-pathname-directory-component pathname-directory) + (=? pathname-name) + (=? pathname-type) + (=? pathname-version))))))) + +(defun* logical-pathname-p (x) + (typep x 'logical-pathname)) + +(defun* physical-pathname-p (x) + (and (pathnamep x) (not (logical-pathname-p x)))) + +(defun* absolute-pathname-p (pathspec) + "If PATHSPEC is a pathname or namestring object that parses as a pathname +possessing an :ABSOLUTE directory component, return the (parsed) pathname. +Otherwise return NIL" + (and pathspec + (typep pathspec '(or null pathname string)) + (let ((pathname (pathname pathspec))) + (and (eq :absolute (car (normalize-pathname-directory-component + (pathname-directory pathname)))) + pathname)))) + +(defun* relative-pathname-p (pathspec) + "If PATHSPEC is a pathname or namestring object that parses as a pathname +possessing a :RELATIVE or NIL directory component, return the (parsed) pathname. +Otherwise return NIL" + (and pathspec + (typep pathspec '(or null pathname string)) + (let* ((pathname (pathname pathspec)) + (directory (normalize-pathname-directory-component + (pathname-directory pathname)))) + (when (or (null directory) (eq :relative (car directory))) + pathname)))) + +(defun* hidden-pathname-p (pathname) + "Return a boolean that is true if the pathname is hidden as per Unix style, +i.e. its name starts with a dot." + (and pathname (equal (first-char (pathname-name pathname)) #\.))) + +(defun* file-pathname-p (pathname) + "Does PATHNAME represent a file, i.e. has a non-null NAME component? + +Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME. + +Note that this does _not_ check to see that PATHNAME points to an +actually-existing file. + +Returns the (parsed) PATHNAME when true" + (when pathname + (let* ((pathname (pathname pathname)) + (name (pathname-name pathname))) + (when (not (member name '(nil :unspecific "") :test 'equal)) + pathname)))) + + +;;; Directory pathnames (defun* pathname-directory-pathname (pathname) "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, and NIL NAME, TYPE and VERSION components" @@ -1575,30 +1922,15 @@ (check-one (pathname-type pathname)) t))))) -(defun* file-pathname-p (pathname) - "Does PATHNAME represent a file, i.e. has a non-null NAME component? - -Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME. - -Note that this does _not_ check to see that PATHNAME points to an -actually-existing file. - -Returns the (parsed) PATHNAME when true" - (when pathname - (let* ((pathname (pathname pathname)) - (name (pathname-name pathname))) - (when (not (member name '(nil :unspecific "") :test 'equal)) - pathname)))) - -(defun* ensure-directory-pathname (pathspec) +(defun* ensure-directory-pathname (pathspec &optional (on-error 'error)) "Converts the non-wild pathname designator PATHSPEC to directory form." (cond ((stringp pathspec) (ensure-directory-pathname (pathname pathspec))) ((not (pathnamep pathspec)) - (error (compatfmt "~@") pathspec)) + (call-function on-error (compatfmt "~@") pathspec)) ((wild-pathname-p pathspec) - (error (compatfmt "~@") pathspec)) + (call-function on-error (compatfmt "~@") pathspec)) ((directory-pathname-p pathspec) pathspec) (t @@ -1609,28 +1941,10 @@ :name nil :type nil :version nil :defaults pathspec)))) -;;; Wildcard pathnames -(defparameter *wild* (or #+cormanlisp "*" :wild)) -(defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild)) -(defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors)) -(defparameter *wild-file* - (make-pathname :directory nil :name *wild* :type *wild* - :version (or #-(or allegro abcl xcl) *wild*))) -(defparameter *wild-directory* - (make-pathname* :directory `(:relative ,*wild-directory-component*) - :name nil :type nil :version nil)) -(defparameter *wild-inferiors* - (make-pathname* :directory `(:relative ,*wild-inferiors-component*) - :name nil :type nil :version nil)) -(defparameter *wild-path* - (merge-pathnames* *wild-file* *wild-inferiors*)) - -(defun* wilden (path) - (merge-pathnames* *wild-path* path)) - - -;;; Probing the filesystem +;;; defaults (defun* nil-pathname (&optional (defaults *default-pathname-defaults*)) + "A pathname that is as neutral as possible for use as defaults + when merging, making or parsing pathnames" ;; 19.2.2.2.1 says a NIL host can mean a default host; ;; see also "valid physical pathname host" in the CLHS glossary, that suggests ;; strings and lists of strings or :unspecific @@ -1640,142 +1954,10 @@ ;; the default shouldn't matter, but we really want something physical :defaults defaults)) -(defmacro with-pathname-defaults ((&optional defaults) &body body) - `(let ((*default-pathname-defaults* ,(or defaults '(nil-pathname)))) , at body)) - -(defun* truename* (p) - ;; avoids both logical-pathname merging and physical resolution issues - (and p (ignore-errors (with-pathname-defaults () (truename p))))) - -(defun* probe-file* (p &key truename) - "when given a pathname P (designated by a string as per PARSE-NAMESTRING), -probes the filesystem for a file or directory with given pathname. -If it exists, return its truename is ENSURE-PATHNAME is true, -or the original (parsed) pathname if it is false (the default)." - (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations - (etypecase p - (null nil) - (string (probe-file* (parse-namestring p) :truename truename)) - (pathname (unless (wild-pathname-p p) - (let ((foundtrue - #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl) - '(probe-file p) - #+clisp (if-let (it (find-symbol* '#:probe-pathname :ext nil)) - `(ignore-errors (,it p))) - #+gcl2.6 - '(or (probe-file p) - (and (directory-pathname-p p) - (ignore-errors - (ensure-directory-pathname - (truename* (subpathname - (ensure-directory-pathname p) ".")))))) - '(truename* p)))) - (cond - (truename foundtrue) - (foundtrue p) - (t nil)))))))) - -(defun* safe-file-write-date (pathname) - ;; If FILE-WRITE-DATE returns NIL, it's possible that - ;; the user or some other agent has deleted an input file. - ;; Also, generated files will not exist at the time planning is done - ;; and calls compute-action-stamp which calls safe-file-write-date. - ;; So it is very possible that we can't get a valid file-write-date, - ;; 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?) - (and (probe-file* pathname) (ignore-errors (file-write-date pathname)))) - -(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) - #+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 nil) - '(:resolve-symlinks nil)))))) - -(defun* filter-logical-directory-results (directory entries merger) - (if (logical-pathname-p directory) - ;; Try hard to not resolve logical-pathname into physical pathnames; - ;; otherwise logical-pathname users/lovers will be disappointed. - ;; If directory* could use some implementation-dependent magic, - ;; we will have logical pathnames already; otherwise, - ;; we only keep pathnames for which specifying the name and - ;; translating the LPN commute. - (loop :for f :in entries - :for p = (or (and (logical-pathname-p f) f) - (let* ((u (ignore-errors (funcall merger f)))) - ;; The first u avoids a cumbersome (truename u) error. - ;; At this point f should already be a truename, - ;; but isn't quite in CLISP, for it doesn't have :version :newest - (and u (equal (truename* u) (truename* f)) u))) - :when p :collect p) - entries)) - -(defun* directory-files (directory &optional (pattern *wild-file*)) - (let ((dir (pathname directory))) - (when (logical-pathname-p dir) - ;; Because of the filtering we do below, - ;; logical pathnames have restrictions on wild patterns. - ;; Not that the results are very portable when you use these patterns on physical pathnames. - (when (wild-pathname-p dir) - (error "Invalid wild pattern in logical directory ~S" directory)) - (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) - (error "Invalid file pattern ~S for logical directory ~S" pattern directory)) - (setf pattern (make-pathname-logical pattern (pathname-host dir)))) - (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir))))) - (filter-logical-directory-results - directory entries - #'(lambda (f) - (make-pathname :defaults dir - :name (make-pathname-component-logical (pathname-name f)) - :type (make-pathname-component-logical (pathname-type f)) - :version (make-pathname-component-logical (pathname-version f)))))))) - -(defun* subdirectories (directory) - (let* ((directory (ensure-directory-pathname directory)) - #-(or abcl cormanlisp genera xcl) - (wild (merge-pathnames* - #-(or abcl allegro cmu lispworks sbcl scl xcl) - *wild-directory* - #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" - directory)) - (dirs - #-(or abcl cormanlisp genera xcl) - (ignore-errors - (directory* wild . #.(or #+clozure '(:directories t :files nil) - #+mcl '(:directories t)))) - #+(or abcl xcl) (system:list-directory directory) - #+cormanlisp (cl::directory-subdirs directory) - #+genera (fs:directory-list directory)) - #+(or abcl allegro cmu genera lispworks sbcl scl xcl) - (dirs (loop :for x :in dirs - :for d = #+(or abcl xcl) (extensions:probe-directory x) - #+allegro (excl:probe-directory x) - #+(or cmu sbcl scl) (directory-pathname-p x) - #+genera (getf (cdr x) :directory) - #+lispworks (lw:file-directory-p x) - :when d :collect #+(or abcl allegro xcl) d - #+genera (ensure-directory-pathname (first x)) - #+(or cmu lispworks sbcl scl) x))) - (filter-logical-directory-results - directory dirs - (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory)) - '(:absolute)))) ; because allegro returns NIL for #p"FOO:" - #'(lambda (d) - (let ((dir (normalize-pathname-directory-component (pathname-directory d)))) - (and (consp dir) (consp (cdr dir)) - (make-pathname - :defaults directory :name nil :type nil :version nil - :directory (append prefix (make-pathname-component-logical (last dir))))))))))) +(defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-homedir-pathname)))) -(defun* collect-sub*directories (directory collectp recursep collector) - (when (funcall collectp directory) - (funcall collector directory)) - (dolist (subdir (subdirectories directory)) - (when (funcall recursep subdir) - (collect-sub*directories subdir collectp recursep collector)))) +(defmacro with-pathname-defaults ((&optional defaults) &body body) + `(let ((*default-pathname-defaults* ,(or defaults '*nil-pathname*))) , at body)) ;;; Parsing filenames and lists thereof @@ -1873,7 +2055,7 @@ which must be one of :BACK or :UP and defaults to :BACK. HOST, DEVICE and VERSION components are taken from DEFAULTS, -which itself defaults to (ROOT-PATHNAME), also used if DEFAULTS in NIL. +which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS in NIL. No host or device can be specified in the string itself, which makes it unsuitable for absolute pathnames outside Unix. @@ -1910,7 +2092,7 @@ (make-pathname* :directory (unless file-only (cons relative path)) :name name :type type - :defaults (or defaults (nil-pathname))) + :defaults (or defaults *nil-pathname*)) (remove-plist-keys '(:type :dot-dot :defaults) keys)))))) (defun* unix-namestring (pathname) @@ -1955,6 +2137,36 @@ (t (or (null type) (err)))))))))) +(defun* native-namestring (x) + "From a non-wildcard CL pathname, a return namestring suitable for passing to the operating system" + (when x + (let ((p (pathname x))) + #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978 + #+(or cmu scl) (ext:unix-namestring p nil) + #+sbcl (sb-ext:native-namestring p) + #-(or clozure cmu sbcl scl) + (if (os-unix-p) (unix-namestring p) + (namestring p))))) + +(defun* parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys) + "From a native namestring suitable for use by the operating system, return +a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" + (check-type string (or string null)) + (let* ((pathname + (when string + (with-pathname-defaults () + #+clozure (ccl:native-to-pathname string) + #+sbcl (sb-ext:parse-native-namestring string) + #-(or clozure sbcl) + (if (os-unix-p) + (parse-unix-namestring string :ensure-directory ensure-directory) + (parse-namestring string))))) + (pathname + (if ensure-directory + (and pathname (ensure-directory-pathname pathname)) + pathname))) + (apply 'ensure-pathname pathname constraints))) + (defun* subpathname (pathname subpath &key type) "This function takes a PATHNAME and a SUBPATH and a TYPE. If SUBPATH is already a PATHNAME object (not namestring), @@ -1971,322 +2183,263 @@ (and pathname (subpathname (ensure-directory-pathname pathname) subpath :type type))) -;;; Pathname host and its root -(defun* pathname-root (pathname) - (make-pathname* :directory '(:absolute) - :name nil :type nil :version nil - :defaults pathname ;; host device, and on scl, *some* - ;; scheme-specific parts: port username password, not others: - . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) - -(defun* pathname-host-pathname (pathname) - (make-pathname* :directory nil - :name nil :type nil :version nil :device nil - :defaults pathname ;; host device, and on scl, *some* - ;; scheme-specific parts: port username password, not others: - . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) - -#-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)) - (absolute-pathname (merge-pathnames* pathname root)) - (separator (directory-separator-for-host root)) - (root-namestring (namestring root)) - (root-string - (substitute-if #\/ - #'(lambda (x) (or (eql x #\:) - (eql x separator))) - root-namestring))) - (multiple-value-bind (relative path filename) - (split-unix-namestring-directory-components root-string :ensure-directory t) - (declare (ignore relative filename)) - (let ((new-base - (make-pathname* :defaults root :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 ((specificp (x) (and x (not (eq x :unspecific))))) - (if (or (specificp port) - (and (specificp host) (plusp (length host))) - (specificp scheme)) - (let ((prefix "")) - (when (specificp port) - (setf prefix (format nil ":~D" port))) - (when (and (specificp host) (plusp (length host))) - (setf prefix (strcat host prefix))) - (setf prefix (strcat ":" prefix)) - (when (specificp scheme) - (setf prefix (strcat scheme prefix))) - (assert (and directory (eq (first directory) :absolute))) - (make-pathname* :directory `(:absolute ,prefix ,@(rest directory)) - :defaults pathname))) - pathname))) - -(defun* subpathp (maybe-subpath base-pathname) - (and (pathnamep maybe-subpath) (pathnamep base-pathname) - (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname) - (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname)) - (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname)) - (with-pathname-defaults () - (let ((enough (enough-namestring maybe-subpath base-pathname))) - (and (relative-pathname-p enough) (pathname enough)))))) - - -;;; Resolving symlinks somewhat -(defun* truenamize (pathname &optional (defaults *default-pathname-defaults*)) - "Resolve as much of a pathname as possible" - (block nil - (when (typep pathname '(or null logical-pathname)) (return pathname)) - (let ((p (merge-pathnames* pathname defaults))) - (when (logical-pathname-p p) (return p)) - (let ((found (probe-file* p :truename t))) - (when found (return found))) - (unless (absolute-pathname-p p) - (let ((true-defaults (truename* defaults))) - (when true-defaults - (setf p (merge-pathnames pathname true-defaults))))) - (unless (absolute-pathname-p p) (return p)) - (let ((sofar (probe-file* (pathname-root p) :truename t))) - (unless sofar (return p)) - (flet ((solution (directories) - (merge-pathnames* - (make-pathname* :host nil :device nil - :directory `(:relative , at directories) - :name (pathname-name p) - :type (pathname-type p) - :version (pathname-version p)) - sofar))) - (loop :with directory = (normalize-pathname-directory-component - (pathname-directory p)) - :for dir :in (cdr directory) - :for rest :on (cdr directory) - :for more = (probe-file* - (merge-pathnames* - (make-pathname* :directory `(:relative ,dir)) - sofar) :truename t) :do - (if more - (setf sofar more) - (return (solution rest))) - :finally - (return (solution nil)))))))) - -(defun* resolve-symlinks (path) - #-allegro (truenamize path) - #+allegro - (if (physical-pathname-p path) - (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path) - path)) - -(defun* resolve-symlinks* (path) - (if *resolve-symlinks* - (and path (resolve-symlinks path)) - path)) - - -;;; absolute vs relative -(defun* ensure-pathname-absolute (path &optional defaults (on-error 'error)) - (cond - ((absolute-pathname-p path)) - ((stringp path) (ensure-pathname-absolute (pathname path) defaults)) - ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path)) - ((absolute-pathname-p defaults) - (or (absolute-pathname-p (merge-pathnames* path defaults)) - (call-function on-error "Failed to merge ~S with ~S into an absolute pathname" - path defaults))) - (t (call-function on-error - "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S" - path defaults)))) -(defun relativize-directory-component (directory-component) - (let ((directory (normalize-pathname-directory-component directory-component))) - (cond - ((stringp directory) - (list :relative directory)) - ((eq (car directory) :absolute) - (cons :relative (cdr directory))) - (t - directory)))) +;;; Wildcard pathnames +(defparameter *wild* (or #+cormanlisp "*" :wild)) +(defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild)) +(defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors)) +(defparameter *wild-file* + (make-pathname :directory nil :name *wild* :type *wild* + :version (or #-(or allegro abcl xcl) *wild*))) +(defparameter *wild-directory* + (make-pathname* :directory `(:relative ,*wild-directory-component*) + :name nil :type nil :version nil)) +(defparameter *wild-inferiors* + (make-pathname* :directory `(:relative ,*wild-inferiors-component*) + :name nil :type nil :version nil)) +(defparameter *wild-path* + (merge-pathnames* *wild-file* *wild-inferiors*)) -(defun* relativize-pathname-directory (pathspec) - (let ((p (pathname pathspec))) - (make-pathname* - :directory (relativize-directory-component (pathname-directory p)) - :defaults p))) +(defun* wilden (path) + (merge-pathnames* *wild-path* path)) -;;; Simple filesystem operations -(defun* ensure-all-directories-exist (pathnames) - (dolist (pathname pathnames) - (ensure-directories-exist (translate-logical-pathname pathname)))) +;;; Probing the filesystem +(defun* truename* (p) + ;; avoids both logical-pathname merging and physical resolution issues + (and p (handler-case (with-pathname-defaults () (truename p)) (file-error () nil)))) -(defun* rename-file-overwriting-target (source target) - #+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic - (posix:copy-file source target :method :rename) - #-clisp - (rename-file source target - #+clozure :if-exists #+clozure :rename-and-delete)) +(defun* safe-file-write-date (pathname) + ;; If FILE-WRITE-DATE returns NIL, it's possible that + ;; the user or some other agent has deleted an input file. + ;; Also, generated files will not exist at the time planning is done + ;; and calls compute-action-stamp which calls safe-file-write-date. + ;; So it is very possible that we can't get a valid file-write-date, + ;; 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?) + (handler-case (file-write-date pathname) (file-error () nil))) -(defun* delete-file-if-exists (x) - (when (probe-file* x) - (delete-file x))) +(defun* probe-file* (p &key truename) + "when given a pathname P (designated by a string as per PARSE-NAMESTRING), +probes the filesystem for a file or directory with given pathname. +If it exists, return its truename is ENSURE-PATHNAME is true, +or the original (parsed) pathname if it is false (the default)." + (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations + (etypecase p + (null nil) + (string (probe-file* (parse-namestring p) :truename truename)) + (pathname + (handler-case + (or + #+allegro + (probe-file p :follow-symlinks truename) + #-(or allegro clisp gcl2.6) + (if truename + (probe-file p) + (and (ignore-errors + #+(or cmu scl) (unix:unix-stat (ext:unix-namestring (translate-logical-pathname p))) + #+(and lispworks unix) (system:get-file-stat p) + #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring (translate-logical-pathname p))) + #-(or cmu (and lispworks unix) sbcl scl) + (file-write-date p)) + p)) + #+(or clisp gcl2.6) + #.(flet ((probe (probe) + `(let ((foundtrue ,probe)) + (cond + (truename foundtrue) + (foundtrue p))))) + #+gcl2.6 + (probe '(or (probe-file p) + (and (directory-pathname-p p) + (ignore-errors + (ensure-directory-pathname + (truename* (subpathname + (ensure-directory-pathname p) "."))))))) + #+clisp + (let ((fs (find-symbol* '#:file-stat :posix nil)) + (pp (find-symbol* '#:probe-pathname :ext nil)) + (resolve (if pp + `(ignore-errors (,pp p)) + '(or (truename* p) + (truename* (ensure-directory-pathname p)))))) + (if fs + `(if truename + ,resolve + (and (,fs p) p)) + (probe resolve))))) + (file-error () nil)))))) -;;; Translate a pathname -(defun* (translate-pathname*) (path absolute-source destination &optional root source) - (declare (ignore source)) - (cond - ((functionp destination) - (funcall destination path absolute-source)) - ((eq destination t) - path) - ((not (pathnamep destination)) - (error "Invalid destination")) - ((not (absolute-pathname-p destination)) - (translate-pathname path absolute-source (merge-pathnames* destination root))) - (root - (translate-pathname (directorize-pathname-host-device path) absolute-source destination)) - (t - (translate-pathname path absolute-source destination)))) +(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) + #+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 nil) + '(:resolve-symlinks nil)))))) +(defun* filter-logical-directory-results (directory entries merger) + (if (logical-pathname-p directory) + ;; Try hard to not resolve logical-pathname into physical pathnames; + ;; otherwise logical-pathname users/lovers will be disappointed. + ;; If directory* could use some implementation-dependent magic, + ;; we will have logical pathnames already; otherwise, + ;; we only keep pathnames for which specifying the name and + ;; translating the LPN commute. + (loop :for f :in entries + :for p = (or (and (logical-pathname-p f) f) + (let* ((u (ignore-errors (funcall merger f)))) + ;; The first u avoids a cumbersome (truename u) error. + ;; At this point f should already be a truename, + ;; but isn't quite in CLISP, for it doesn't have :version :newest + (and u (equal (truename* u) (truename* f)) u))) + :when p :collect p) + entries)) -;;; Temporary pathnames -(defun* add-pathname-suffix (pathname suffix) - (make-pathname :name (strcat (pathname-name pathname) suffix) - :defaults pathname)) +(defun* directory-files (directory &optional (pattern *wild-file*)) + (let ((dir (pathname directory))) + (when (logical-pathname-p dir) + ;; Because of the filtering we do below, + ;; logical pathnames have restrictions on wild patterns. + ;; Not that the results are very portable when you use these patterns on physical pathnames. + (when (wild-pathname-p dir) + (error "Invalid wild pattern in logical directory ~S" directory)) + (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) + (error "Invalid file pattern ~S for logical directory ~S" pattern directory)) + (setf pattern (make-pathname-logical pattern (pathname-host dir)))) + (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir))))) + (filter-logical-directory-results + directory entries + #'(lambda (f) + (make-pathname :defaults dir + :name (make-pathname-component-logical (pathname-name f)) + :type (make-pathname-component-logical (pathname-type f)) + :version (make-pathname-component-logical (pathname-version f)))))))) -(defun* tmpize-pathname (x) - (add-pathname-suffix x "-ASDF-TMP")) +(defun* subdirectories (directory) + (let* ((directory (ensure-directory-pathname directory)) + #-(or abcl cormanlisp genera xcl) + (wild (merge-pathnames* + #-(or abcl allegro cmu lispworks sbcl scl xcl) + *wild-directory* + #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" + directory)) + (dirs + #-(or abcl cormanlisp genera xcl) + (ignore-errors + (directory* wild . #.(or #+clozure '(:directories t :files nil) + #+mcl '(:directories t)))) + #+(or abcl xcl) (system:list-directory directory) + #+cormanlisp (cl::directory-subdirs directory) + #+genera (fs:directory-list directory)) + #+(or abcl allegro cmu genera lispworks sbcl scl xcl) + (dirs (loop :for x :in dirs + :for d = #+(or abcl xcl) (extensions:probe-directory x) + #+allegro (excl:probe-directory x) + #+(or cmu sbcl scl) (directory-pathname-p x) + #+genera (getf (cdr x) :directory) + #+lispworks (lw:file-directory-p x) + :when d :collect #+(or abcl allegro xcl) d + #+genera (ensure-directory-pathname (first x)) + #+(or cmu lispworks sbcl scl) x))) + (filter-logical-directory-results + directory dirs + (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory)) + '(:absolute)))) ; because allegro returns NIL for #p"FOO:" + #'(lambda (d) + (let ((dir (normalize-pathname-directory-component (pathname-directory d)))) + (and (consp dir) (consp (cdr dir)) + (make-pathname + :defaults directory :name nil :type nil :version nil + :directory (append prefix (make-pathname-component-logical (last dir))))))))))) -(defun* call-with-staging-pathname (pathname fun) - "Calls fun with a staging pathname, and atomically -renames the staging pathname to the pathname in the end. -Note: this protects only against failure of the program, -not against concurrent attempts. -For the latter case, we ought pick random suffix and atomically open it." - (let* ((pathname (pathname pathname)) - (staging (tmpize-pathname pathname))) - (unwind-protect - (multiple-value-prog1 - (funcall fun staging) - (rename-file-overwriting-target staging pathname)) - (delete-file-if-exists staging)))) +(defun* collect-sub*directories (directory collectp recursep collector) + (when (funcall collectp directory) + (funcall collector directory)) + (dolist (subdir (subdirectories directory)) + (when (funcall recursep subdir) + (collect-sub*directories subdir collectp recursep collector)))) -(defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body) - `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) , at body))) -;;; Basic pathnames -(defun* sane-physical-pathname (&key defaults (keep t) fallback want-existing) - (flet ((sanitize (x) - (setf x (and x (ignore-errors (translate-logical-pathname x)))) - (when (pathnamep x) - (setf x - (ecase keep - ((t) x) - ((:directory) (pathname-directory-pathname x)) - ((:root) (pathname-root x)) - ((:host) (pathname-host-pathname x)) - ((nil) (nil-pathname x)))) - (when want-existing ;; CCL's probe-file will choke if d-p-d is logical - (setf x (probe-file* x))) - (and (physical-pathname-p x) x)))) - (or (sanitize defaults) - (when fallback - (or (sanitize (nil-pathname)) - (sanitize (ignore-errors (user-homedir-pathname))))) - (error "Could not find a sane a physical pathname~ - ~@[ from ~S~]~@[~:*~@[ or~*~] fallbacks~]" - defaults fallback)))) - -(defun* root-pathname () - "On a Unix system, this will presumably be the root pathname /. -Otherwise, this will be the root of some implementation-dependent filesystem host." - (sane-physical-pathname :keep :root :fallback t)) +;;; Pathname host and its root +(defun* pathname-root (pathname) + (make-pathname* :directory '(:absolute) + :name nil :type nil :version nil + :defaults pathname ;; host device, and on scl, *some* + ;; scheme-specific parts: port username password, not others: + . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) +(defun* pathname-host-pathname (pathname) + (make-pathname* :directory nil + :name nil :type nil :version nil :device nil + :defaults pathname ;; host device, and on scl, *some* + ;; scheme-specific parts: port username password, not others: + . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) -;;;; ----------------------------------------------------------------- -;;;; Windows shortcut support. Based on: -;;;; -;;;; Jesse Hager: The Windows Shortcut File Format. -;;;; http://www.wotsit.org/list.asp?fc=13 +(defun* subpathp (maybe-subpath base-pathname) + (and (pathnamep maybe-subpath) (pathnamep base-pathname) + (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname) + (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname)) + (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname)) + (with-pathname-defaults () + (let ((enough (enough-namestring maybe-subpath base-pathname))) + (and (relative-pathname-p enough) (pathname enough)))))) -#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera. -(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)) +(defun* ensure-pathname-absolute (path &optional defaults (on-error 'error)) + (cond + ((absolute-pathname-p path)) + ((stringp path) (ensure-pathname-absolute (pathname path) defaults)) + ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path)) + ((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults)))) + (or (if (absolute-pathname-p default-pathname) + (absolute-pathname-p (merge-pathnames* path default-pathname)) + (call-function on-error "Default pathname ~S is not an absolute pathname" + default-pathname)) + (call-function on-error "Failed to merge ~S with ~S into an absolute pathname" + path default-pathname)))) + (t (call-function on-error + "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S" + path defaults)))) -(defun* read-null-terminated-string (s) - (with-output-to-string (out) - (loop :for code = (read-byte s) - :until (zerop code) - :do (write-char (code-char code) out)))) -(defun* read-little-endian (s &optional (bytes 4)) - (loop :for i :from 0 :below bytes - :sum (ash (read-byte s) (* 8 i)))) +;;; Resolving symlinks somewhat +(defun* truenamize (pathname) + "Resolve as much of a pathname as possible" + (block nil + (when (typep pathname '(or null logical-pathname)) (return pathname)) + (let ((p pathname)) + (unless (absolute-pathname-p p) + (setf p (or (absolute-pathname-p (ensure-pathname-absolute p 'get-pathname-defaults nil)) + (return p)))) + (when (logical-pathname-p p) (return p)) + (let ((found (probe-file* p :truename t))) + (when found (return found))) + (let* ((directory (normalize-pathname-directory-component (pathname-directory p))) + (up-components (reverse (rest directory))) + (down-components ())) + (assert (eq :absolute (first directory))) + (loop :while up-components :do + (if-let (parent (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components)) + :name nil :type nil :version nil :defaults p))) + (return (merge-pathnames* (make-pathname* :directory `(:relative , at down-components) + :defaults p) + (ensure-directory-pathname parent))) + (push (pop up-components) down-components)) + :finally (return p)))))) -(defun* parse-file-location-info (s) - (let ((start (file-position s)) - (total-length (read-little-endian s)) - (end-of-header (read-little-endian s)) - (fli-flags (read-little-endian s)) - (local-volume-offset (read-little-endian s)) - (local-offset (read-little-endian s)) - (network-volume-offset (read-little-endian s)) - (remaining-offset (read-little-endian s))) - (declare (ignore total-length end-of-header local-volume-offset)) - (unless (zerop fli-flags) - (cond - ((logbitp 0 fli-flags) - (file-position s (+ start local-offset))) - ((logbitp 1 fli-flags) - (file-position s (+ start - network-volume-offset - #x14)))) - (strcat (read-null-terminated-string s) - (progn - (file-position s (+ start remaining-offset)) - (read-null-terminated-string s)))))) +(defun* resolve-symlinks (path) + #-allegro (truenamize path) + #+allegro + (if (physical-pathname-p path) + (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path) + path)) -(defun* parse-windows-shortcut (pathname) - (with-open-file (s pathname :element-type '(unsigned-byte 8)) - (handler-case - (when (and (= (read-little-endian s) *link-initial-dword*) - (let ((header (make-array (length *link-guid*)))) - (read-sequence header s) - (equalp header *link-guid*))) - (let ((flags (read-little-endian s))) - (file-position s 76) ;skip rest of header - (when (logbitp 0 flags) - ;; skip shell item id list - (let ((length (read-little-endian s 2))) - (file-position s (+ length (file-position s))))) - (cond - ((logbitp 1 flags) - (parse-file-location-info s)) - (t - (when (logbitp 2 flags) - ;; skip description string - (let ((length (read-little-endian s 2))) - (file-position s (+ length (file-position s))))) - (when (logbitp 3 flags) - ;; finally, our pathname - (let* ((length (read-little-endian s 2)) - (buffer (make-array length))) - (read-sequence buffer s) - (map 'string #'code-char buffer))))))) - (end-of-file (c) - (declare (ignore c)) - nil))))) +(defun* resolve-symlinks* (path) + (if *resolve-symlinks* + (and path (resolve-symlinks path)) + path)) ;;; Check pathname constraints @@ -2410,39 +2563,167 @@ p)))) -(defun absolutize-pathnames - (pathnames &key type (resolve-symlinks *resolve-symlinks*) truename) - "Given a list of PATHNAMES where each is in the context of the next ones, -try to resolve these pathnames into an absolute pathname; first gently, then harder." - (block nil - (labels ((resolve (x) - (or (when truename - (absolute-pathname-p (truename* x))) - (when resolve-symlinks - (absolute-pathname-p (resolve-symlinks x))) - (absolute-pathname-p x) - (unless resolve-symlinks - (absolute-pathname-p (resolve-symlinks x))) - (unless truename - (absolute-pathname-p (truename* x))) - (return nil))) - (tryone (x type rest) - (resolve (or (absolute-pathname-p x) - (subpathname (recurse rest :directory) x :type type)))) - (recurse (pathnames type) - (if (null pathnames) (return nil) - (tryone (first pathnames) type (rest pathnames))))) - (recurse pathnames type)))) +;;; Environment pathnames +(defun* inter-directory-separator () + (if (os-unix-p) #\: #\;)) + +(defun* split-native-pathnames-string (string &rest constraints &key &allow-other-keys) + (loop :for namestring :in (split-string string :separator (string (inter-directory-separator))) + :collect (apply 'parse-native-namestring namestring constraints))) + +(defun* getenv-pathname (x &rest constraints &key on-error &allow-other-keys) + (apply 'parse-native-namestring (getenvp x) + :on-error (or on-error + `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x)) + constraints)) +(defun* getenv-pathnames (x &rest constraints &key on-error &allow-other-keys) + (apply 'split-native-pathnames-string (getenvp x) + :on-error (or on-error + `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x)) + constraints)) +(defun* getenv-absolute-directory (x) + (getenv-pathname x :want-absolute t :ensure-directory t)) +(defun* getenv-absolute-directories (x) + (getenv-pathnames x :want-absolute t :ensure-directory t)) + +(defun* lisp-implementation-directory (&key truename) + (let ((dir + (ignore-errors + #+clozure #p"ccl:" + #+(or ecl mkcl) #p"SYS:" + #+gcl system::*system-directory* + #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil)) + (funcall it) + (getenv-pathname "SBCL_HOME" :ensure-directory t))))) + (if (and dir truename) + (truename* dir) + dir))) + +(defun* lisp-implementation-pathname-p (pathname) + ;; Other builtin systems are those under the implementation directory + (and (when pathname + (if-let (impdir (lisp-implementation-directory)) + (or (subpathp pathname impdir) + (when *resolve-symlinks* + (if-let (truename (truename* pathname)) + (if-let (trueimpdir (truename* impdir)) + (subpathp truename trueimpdir))))))) + t)) + + +;;; Pathname defaults and current directory +(defun* get-pathname-defaults (&optional (defaults *default-pathname-defaults*)) + (or (absolute-pathname-p defaults) + (merge-pathnames* defaults (getcwd)))) + +(defun* call-with-current-directory (dir thunk) + (if dir + (let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir)))) + (*default-pathname-defaults* dir) + (cwd (getcwd))) + (chdir dir) + (unwind-protect + (funcall thunk) + (chdir cwd))) + (funcall thunk))) + +(defmacro with-current-directory ((&optional dir) &body body) + "Call BODY while the POSIX current working directory is set to DIR" + `(call-with-current-directory ,dir #'(lambda () , at body))) + + +;;; Translate a pathname +(defun relativize-directory-component (directory-component) + (let ((directory (normalize-pathname-directory-component directory-component))) + (cond + ((stringp directory) + (list :relative directory)) + ((eq (car directory) :absolute) + (cons :relative (cdr directory))) + (t + directory)))) + +(defun* relativize-pathname-directory (pathspec) + (let ((p (pathname pathspec))) + (make-pathname* + :directory (relativize-directory-component (pathname-directory p)) + :defaults p))) + +(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) + #+(or unix abcl) + (when (and #+abcl (os-unix-p) (physical-pathname-p pathname)) + (return-from directorize-pathname-host-device pathname)) + (let* ((root (pathname-root pathname)) + (wild-root (wilden root)) + (absolute-pathname (merge-pathnames* pathname root)) + (separator (directory-separator-for-host root)) + (root-namestring (namestring root)) + (root-string + (substitute-if #\/ + #'(lambda (x) (or (eql x #\:) + (eql x separator))) + root-namestring))) + (multiple-value-bind (relative path filename) + (split-unix-namestring-directory-components root-string :ensure-directory t) + (declare (ignore relative filename)) + (let ((new-base + (make-pathname* :defaults root :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 ((specificp (x) (and x (not (eq x :unspecific))))) + (if (or (specificp port) + (and (specificp host) (plusp (length host))) + (specificp scheme)) + (let ((prefix "")) + (when (specificp port) + (setf prefix (format nil ":~D" port))) + (when (and (specificp host) (plusp (length host))) + (setf prefix (strcat host prefix))) + (setf prefix (strcat ":" prefix)) + (when (specificp scheme) + (setf prefix (strcat scheme prefix))) + (assert (and directory (eq (first directory) :absolute))) + (make-pathname* :directory `(:absolute ,prefix ,@(rest directory)) + :defaults pathname))) + pathname))) +(defun* (translate-pathname*) (path absolute-source destination &optional root source) + (declare (ignore source)) + (cond + ((functionp destination) + (funcall destination path absolute-source)) + ((eq destination t) + path) + ((not (pathnamep destination)) + (error "Invalid destination")) + ((not (absolute-pathname-p destination)) + (translate-pathname path absolute-source (merge-pathnames* destination root))) + (root + (translate-pathname (directorize-pathname-host-device path) absolute-source destination)) + (t + (translate-pathname path absolute-source destination)))) ;;; Hook for output translations (defvar *output-translation-function* 'identity) + + ;;;; --------------------------------------------------------------------------- ;;;; Utilities related to streams (asdf/package:define-package :asdf/stream (:recycle :asdf/stream) - (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/pathname) + (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathname) (:export #:*default-stream-element-type* #:*stderr* #:setup-stderr #:with-safe-io-syntax #:call-with-safe-io-syntax @@ -2457,7 +2738,15 @@ #:eval-input #:eval-thunk #:standard-eval-thunk #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format - #:*default-encoding* #:*utf-8-external-format*)) + #:*default-encoding* #:*utf-8-external-format* + #:ensure-all-directories-exist + #:rename-file-overwriting-target + #:delete-file-if-exists + #:*temporary-directory* #:temporary-directory #:default-temporary-directory + #:setup-temporary-directory + #:call-with-temporary-file #:with-temporary-file + #:add-pathname-suffix #:tmpize-pathname + #:call-with-staging-pathname #:with-staging-pathname)) (in-package :asdf/stream) (defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default) @@ -2735,385 +3024,79 @@ (defun* standard-eval-thunk (thunk &key (package :cl)) "Like EVAL-THUNK, but in a more standardized evaluation context." - ;; Note: it's "standard-" not "safe-", because evaluation is never safe. - (when thunk - (with-safe-io-syntax (:package package) - (let ((*read-eval* t)) - (eval-thunk thunk))))) - - -;;; Encodings - -(defvar *default-encoding* :default - "Default encoding for source files. -The default value :default preserves the legacy behavior. -A future default might be :utf-8 or :autodetect -reading emacs-style -*- coding: utf-8 -*- specifications, -and falling back to utf-8 or latin1 if nothing is specified.") - -(defparameter *utf-8-external-format* - #+(and asdf-unicode (not clisp)) :utf-8 - #+(and asdf-unicode clisp) charset:utf-8 - #-asdf-unicode :default - "Default :external-format argument to pass to CL:OPEN and also -CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file. -On modern implementations, this will decode UTF-8 code points as CL characters. -On legacy implementations, it may fall back on some 8-bit encoding, -with non-ASCII code points being read as several CL characters; -hopefully, if done consistently, that won't affect program behavior too much.") - -(defun* always-default-encoding (pathname) - (declare (ignore pathname)) - *default-encoding*) - -(defvar *encoding-detection-hook* #'always-default-encoding - "Hook for an extension to define a function to automatically detect a file's encoding") - -(defun* detect-encoding (pathname) - (if (and pathname (not (directory-pathname-p pathname)) (probe-file pathname)) - (funcall *encoding-detection-hook* pathname) - *default-encoding*)) - -(defun* default-encoding-external-format (encoding) - (case encoding - (:default :default) ;; for backward-compatibility only. Explicit usage discouraged. - (:utf-8 *utf-8-external-format*) - (otherwise - (cerror "Continue using :external-format :default" (compatfmt "~@") encoding) - :default))) - -(defvar *encoding-external-format-hook* - #'default-encoding-external-format - "Hook for an extension to define a mapping between non-default encodings -and implementation-defined external-format's") - -(defun* encoding-external-format (encoding) - (funcall *encoding-external-format-hook* encoding)) - -;;;; --------------------------------------------------------------------------- -;;;; Access to the Operating System - -(asdf/package:define-package :asdf/os - (:recycle :asdf/os :asdf) - (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/pathname :asdf/stream) - (:export - #:featurep #:os-unix-p #:os-windows-p ;; features - #:getenv #:getenvp ;; environment variables - #:native-namestring #:parse-native-namestring - #:inter-directory-separator #:split-native-pathnames-string - #:getenv-pathname #:getenv-pathnames - #:getenv-absolute-directory #:getenv-absolute-directories - #:implementation-identifier ;; implementation identifier - #:implementation-type #:*implementation-type* - #:operating-system #:architecture #:lisp-version-string - #:hostname #:user-homedir #:lisp-implementation-directory - #:getcwd #:chdir #:call-with-current-directory #:with-current-directory - #:*temporary-directory* #:temporary-directory #:default-temporary-directory - #:setup-temporary-directory - #:call-with-temporary-file #:with-temporary-file)) -(in-package :asdf/os) - -;;; Features -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun* featurep (x &optional (*features* *features*)) - (cond - ((atom x) (and (member x *features*) t)) - ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x)))) - ((eq :or (car x)) (some #'featurep (cdr x))) - ((eq :and (car x)) (every #'featurep (cdr x))) - (t (error "Malformed feature specification ~S" x)))) - - (defun* os-unix-p () - (featurep '(:or :unix :cygwin :darwin))) - - (defun* os-windows-p () - (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32)))) - - (defun* os-genera-p () - (featurep :genera)) - - (defun* detect-os () - (flet ((yes (yes) (pushnew yes *features*)) - (no (no) (setf *features* (remove no *features*)))) - (cond - ((os-unix-p) (yes :os-unix) (no :os-windows)) - ((os-windows-p) (yes :os-windows) (no :os-unix)) - ((os-genera-p) (no :os-unix) (no :os-windows)) - (t (error "Congratulations for trying XCVB on an operating system~%~ -that is neither Unix, nor Windows, nor even Genera.~%Now you port it."))))) - - (detect-os)) - -;;;; Environment variables: getting them, and parsing them. - -(defun* getenv (x) - (declare (ignorable x)) - #+(or abcl clisp ecl xcl) (ext:getenv x) - #+allegro (sys:getenv x) - #+clozure (ccl:getenv x) - #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=)) - #+cormanlisp - (let* ((buffer (ct:malloc 1)) - (cname (ct:lisp-string-to-c-string x)) - (needed-size (win:getenvironmentvariable cname buffer 0)) - (buffer1 (ct:malloc (1+ needed-size)))) - (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size)) - nil - (ct:c-string-to-lisp-string buffer1)) - (ct:free buffer) - (ct:free buffer1))) - #+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)))) - #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x) - #+sbcl (sb-ext:posix-getenv x) - #-(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* getenvp (x) - "Predicate that is true if the named variable is present in the libc environment, -then returning the non-empty string value of the variable" - (let ((g (getenv x))) (and (not (emptyp g)) g))) - - -;;; Native vs Lisp syntax - -(defun* native-namestring (x) - "From a CL pathname, a return namestring suitable for passing to the operating system" - (when x - (let ((p (pathname x))) - #+clozure (with-pathname-defaults ((root-pathname)) - (ccl:native-translated-namestring p)) ; see ccl bug 978 - #+(or cmu scl) (ext:unix-namestring p nil) - #+sbcl (sb-ext:native-namestring p) - #-(or clozure cmu sbcl scl) - (if (os-unix-p) (unix-namestring p) - (namestring p))))) - -(defun* parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys) - "From a native namestring suitable for use by the operating system, return -a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" - (check-type string (or string null)) - (let* ((pathname - (when string - (with-pathname-defaults ((root-pathname)) - #+clozure (ccl:native-to-pathname string) - #+sbcl (sb-ext:parse-native-namestring string) - #-(or clozure sbcl) - (if (os-unix-p) - (parse-unix-namestring string :ensure-directory ensure-directory) - (parse-namestring string))))) - (pathname - (if ensure-directory - (and pathname (ensure-directory-pathname pathname)) - pathname))) - (apply 'ensure-pathname pathname constraints))) - - -;;; Native pathnames in environment -(defun* inter-directory-separator () - (if (os-unix-p) #\: #\;)) -(defun* split-native-pathnames-string (string &rest constraints &key &allow-other-keys) - (loop :for namestring :in (split-string string :separator (string (inter-directory-separator))) - :collect (apply 'parse-native-namestring namestring constraints))) -(defun* getenv-pathname (x &rest constraints &key on-error &allow-other-keys) - (apply 'parse-native-namestring (getenvp x) - :on-error (or on-error - `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x)) - constraints)) -(defun* getenv-pathnames (x &rest constraints &key on-error &allow-other-keys) - (apply 'split-native-pathnames-string (getenvp x) - :on-error (or on-error - `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x)) - constraints)) -(defun* getenv-absolute-directory (x) - (getenv-pathname x :want-absolute t :ensure-directory t)) -(defun* getenv-absolute-directories (x) - (getenv-pathnames x :want-absolute t :ensure-directory t)) - - -;;;; implementation-identifier -;; -;; produce a string to identify current implementation. -;; Initially stolen from SLIME's SWANK, completely rewritten since. -;; We're back to runtime checking, for the sake of e.g. ABCL. - -(defun* first-feature (feature-sets) - (dolist (x feature-sets) - (multiple-value-bind (short long feature-expr) - (if (consp x) - (values (first x) (second x) (cons :or (rest x))) - (values x x x)) - (when (featurep feature-expr) - (return (values short long)))))) - -(defun* implementation-type () - (first-feature - '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) - (:cmu :cmucl :cmu) :ecl :gcl - (:lwpe :lispworks-personal-edition) (:lw :lispworks) - :mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl))) - -(defvar *implementation-type* (implementation-type)) - -(defun* operating-system () - (first-feature - '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! - (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd - (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd - (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix - :genera))) - -(defun* architecture () - (first-feature - '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386)) - (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target) - (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc) - :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc) - :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach - ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI, - ;; we may have to segregate the code still by architecture. - (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))) + ;; Note: it's "standard-" not "safe-", because evaluation is never safe. + (when thunk + (with-safe-io-syntax (:package package) + (let ((*read-eval* t)) + (eval-thunk thunk))))) -#+clozure -(defun* ccl-fasl-version () - ;; the fasl version is target-dependent from CCL 1.8 on. - (or (let ((s 'ccl::target-fasl-version)) - (and (fboundp s) (funcall s))) - (and (boundp 'ccl::fasl-version) - (symbol-value 'ccl::fasl-version)) - (error "Can't determine fasl version."))) -(defun* lisp-version-string () - (let ((s (lisp-implementation-version))) - (car ; as opposed to OR, this idiom prevents some unreachable code warning - (list - #+allegro - (format nil "~A~@[~A~]~@[~A~]~@[~A~]" - excl::*common-lisp-version-number* - ;; 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")) - (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.) - #+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) - #+scl (format nil "~A~A" s - ;; ANSI upper case vs lower case. - (ecase ext:*case-mode* (:upper "") (:lower "l"))) - #+ecl (format nil "~A~@[-~A~]" s - (let ((vcs-id (ext:lisp-implementation-vcs-id))) - (subseq vcs-id 0 (min (length vcs-id) 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)) - #+mcl (subseq s 8) ; strip the leading "Version " - s)))) +;;; Encodings -(defun* implementation-identifier () - (substitute-if - #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\"")) - (format nil "~(~a~@{~@[-~a~]~}~)" - (or (implementation-type) (lisp-implementation-type)) - (or (lisp-version-string) (lisp-implementation-version)) - (or (operating-system) (software-type)) - (or (architecture) (machine-type))))) +(defvar *default-encoding* :default + "Default encoding for source files. +The default value :default preserves the legacy behavior. +A future default might be :utf-8 or :autodetect +reading emacs-style -*- coding: utf-8 -*- specifications, +and falling back to utf-8 or latin1 if nothing is specified.") +(defparameter *utf-8-external-format* + #+(and asdf-unicode (not clisp)) :utf-8 + #+(and asdf-unicode clisp) charset:utf-8 + #-asdf-unicode :default + "Default :external-format argument to pass to CL:OPEN and also +CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file. +On modern implementations, this will decode UTF-8 code points as CL characters. +On legacy implementations, it may fall back on some 8-bit encoding, +with non-ASCII code points being read as several CL characters; +hopefully, if done consistently, that won't affect program behavior too much.") -;;;; Other system information +(defun* always-default-encoding (pathname) + (declare (ignore pathname)) + *default-encoding*) -(defun* hostname () - ;; Note: untested on RMCL - #+(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 (symbol-call :excl.osi :gethostname) - #+clisp (first (split-string (machine-instance) :separator " ")) - #+gcl (system:gethostname)) +(defvar *encoding-detection-hook* #'always-default-encoding + "Hook for an extension to define a function to automatically detect a file's encoding") -(defun* user-homedir () - (truenamize - (pathname-directory-pathname - #+cormanlisp (ensure-directory-pathname (user-homedir-pathname)) - #+mcl (current-user-homedir-pathname) - #-(or cormanlisp mcl) (user-homedir-pathname)))) +(defun* detect-encoding (pathname) + (if (and pathname (not (directory-pathname-p pathname)) (probe-file pathname)) + (funcall *encoding-detection-hook* pathname) + *default-encoding*)) -(defun* lisp-implementation-directory (&key truename) - (let ((dir - (ignore-errors - #+clozure #p"ccl:" - #+(or ecl mkcl) #p"SYS:" - #+gcl system::*system-directory* - #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil)) - (funcall it) - (getenv-pathname "SBCL_HOME" :ensure-directory t))))) - (if (and dir truename) - (truename* dir) - dir))) +(defun* default-encoding-external-format (encoding) + (case encoding + (:default :default) ;; for backward-compatibility only. Explicit usage discouraged. + (:utf-8 *utf-8-external-format*) + (otherwise + (cerror "Continue using :external-format :default" (compatfmt "~@") encoding) + :default))) +(defvar *encoding-external-format-hook* + #'default-encoding-external-format + "Hook for an extension to define a mapping between non-default encodings +and implementation-defined external-format's") -;;; Current directory +(defun* encoding-external-format (encoding) + (funcall *encoding-external-format-hook* encoding)) -(defun* getcwd () - "Get the current working directory as per POSIX getcwd(3), as a pathname object" - (or #+abcl (parse-native-namestring - (java:jstatic "getProperty" "java.lang.System" "user.dir") :ensure-directory t) - #+allegro (excl::current-directory) - #+clisp (ext:default-directory) - #+clozure (ccl:current-directory) - #+(or cmu scl) (parse-native-namestring - (nth-value 1 (unix:unix-current-directory)) :ensure-directory t) - #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return? - #+ecl (ext:getcwd) - #+gcl (parse-native-namestring ;; this is a joke. Isn't there a better way? - (first (symbol-call :asdf/driver :run-program '("/bin/pwd") :output :lines))) - #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical! - #+lispworks (system:current-directory) - #+mkcl (mk-ext:getcwd) - #+sbcl (parse-native-namestring (sb-unix:posix-getcwd/)) - #+xcl (extensions:current-directory) - (error "getcwd not supported on your implementation"))) -(defun* chdir (x) - "Change current directory, as per POSIX chdir(2)" - #-(or clisp clozure) (when (pathnamep x) (setf x (native-namestring x))) - (or #+clisp (ext:cd x) - #+clozure (setf (ccl:current-directory) x) - #+cormanlisp (unless (zerop (win32::_chdir x)) - (error "Could not set current directory to ~A" x)) - #+sbcl (symbol-call :sb-posix :chdir x) - (error "chdir not supported on your implementation"))) +;;; Simple filesystem operations +(defun* ensure-all-directories-exist (pathnames) + (dolist (pathname pathnames) + (ensure-directories-exist (translate-logical-pathname pathname)))) -(defun* call-with-current-directory (dir thunk) - (if dir - (let* ((dir (truename (merge-pathnames (pathname-directory-pathname dir)))) - (*default-pathname-defaults* dir) - (cwd (getcwd))) - (chdir dir) - (unwind-protect - (funcall thunk) - (chdir cwd))) - (funcall thunk))) +(defun* rename-file-overwriting-target (source target) + #+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic + (posix:copy-file source target :method :rename) + #-clisp + (rename-file source target + #+clozure :if-exists #+clozure :rename-and-delete)) -(defmacro with-current-directory ((dir) &body body) - "Call BODY while the POSIX current working directory is set to DIR" - `(call-with-current-directory ,dir #'(lambda () , at body))) +(defun* delete-file-if-exists (x) + (handler-case (delete-file x) (file-error () nil))) ;;; Using temporary files - (defun* default-temporary-directory () (or (when (os-unix-p) @@ -3121,7 +3104,7 @@ (parse-native-namestring "/tmp/"))) (when (os-windows-p) (getenv-pathname "TEMP" :ensure-directory t)) - (subpathname (user-homedir) "tmp/"))) + (subpathname (user-homedir-pathname) "tmp/"))) (defvar *temporary-directory* nil) @@ -3182,6 +3165,32 @@ ,@(when element-type `(:element-type ,element-type)) ,@(when external-format `(:external-format external-format))))) +;;; Temporary pathnames +(defun* add-pathname-suffix (pathname suffix) + (make-pathname :name (strcat (pathname-name pathname) suffix) + :defaults pathname)) + +(defun* tmpize-pathname (x) + (add-pathname-suffix x "-ASDF-TMP")) + +(defun* call-with-staging-pathname (pathname fun) + "Calls fun with a staging pathname, and atomically +renames the staging pathname to the pathname in the end. +Note: this protects only against failure of the program, +not against concurrent attempts. +For the latter case, we ought pick random suffix and atomically open it." + (let* ((pathname (pathname pathname)) + (staging (tmpize-pathname pathname))) + (unwind-protect + (multiple-value-prog1 + (funcall fun staging) + (rename-file-overwriting-target staging pathname)) + (delete-file-if-exists staging)))) + +(defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body) + `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) , at body))) + + ;;;; ------------------------------------------------------------------------- ;;;; Starting, Stopping, Dumping a Lisp image @@ -3502,7 +3511,8 @@ ;;; Some universal image restore hooks (map () 'register-image-restore-hook - '(setup-temporary-directory setup-stderr setup-command-line-arguments)) + '(setup-temporary-directory setup-stderr setup-command-line-arguments + #+abcl detect-os)) ;;;; ------------------------------------------------------------------------- ;;;; run-program initially from xcvb-driver. @@ -3907,7 +3917,6 @@ #:compile-warned-warning #:compile-failed-warning #:check-lisp-compile-results #:check-lisp-compile-warnings #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions* - #:*deferred-warnings* ;; Functions & Macros #:get-optimization-settings #:proclaim-optimization-settings #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions @@ -3915,7 +3924,7 @@ #:reify-simple-sexp #:unreify-simple-sexp #:reify-deferred-warnings #:reify-undefined-warning #:unreify-deferred-warnings #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings - #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type + #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:*warnings-file-type* #:call-with-asdf-compilation-unit #:with-asdf-compilation-unit #:current-lisp-file-pathname #:load-pathname #:lispize-pathname #:compile-file-type #:call-around-hook @@ -4003,9 +4012,6 @@ #+clisp '(clos::simple-gf-replacing-method-warning)) "Additional conditions that may be skipped while loading") -(defvar *deferred-warnings* () - "Warnings the handling of which is deferred until the end of the compilation unit") - ;;;; ----- Filtering conditions while building ----- (defun* call-with-muffled-compiler-conditions (thunk) @@ -4074,6 +4080,10 @@ ;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman. +;; +;; To support an implementation, three functions must be implemented: +;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-warnings +;; See their respective docstrings. (defun reify-simple-sexp (sexp) (etypecase sexp @@ -4138,6 +4148,9 @@ (sb-c::undefined-warning-warnings warning)))) (defun reify-deferred-warnings () + "return a portable S-expression, portably readable and writeable in any Common Lisp implementation +using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently deferred by +WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF." #+clozure (mapcar 'reify-deferred-warning (if-let (dw ccl::*outstanding-deferred-warnings*) @@ -4159,6 +4172,11 @@ :collect `(,what . ,value))))) (defun unreify-deferred-warnings (reified-deferred-warnings) + "given a S-expression created by REIFY-DEFERRED-WARNINGS, reinstantiate the corresponding +deferred warnings as to be handled at the end of the current WITH-COMPILATION-UNIT. +Handle any warning that has been resolved already, +such as an undefined function that has been defined since. +One of three functions required for deferred-warnings support in ASDF." (declare (ignorable reified-deferred-warnings)) #+clozure (let ((dw (or ccl::*outstanding-deferred-warnings* @@ -4193,6 +4211,8 @@ (set symbol (+ (symbol-value symbol) adjustment))))))) (defun reset-deferred-warnings () + "Reset the set of deferred warnings to be handled at the end of the current WITH-COMPILATION-UNIT. +One of three functions required for deferred-warnings support in ASDF." #+clozure (if-let (dw ccl::*outstanding-deferred-warnings*) (let ((mdw (ccl::ensure-merged-deferred-warnings dw))) @@ -4220,8 +4240,13 @@ (:sbcl "sbcl-warnings") ((:clozure :ccl) "ccl-warnings"))) +(defvar *warnings-file-type* (warnings-file-type) + "Type for warnings files") + (defun* warnings-file-p (file &optional implementation-type) - (if-let (type (warnings-file-type implementation-type)) + (if-let (type (if implementation-type + (warnings-file-type implementation-type) + *warnings-file-type*)) (equal (pathname-type file) type))) (defun* check-deferred-warnings (files &optional context-format context-arguments) @@ -4272,8 +4297,7 @@ (defun* call-with-saved-deferred-warnings (thunk warnings-file) (if warnings-file (with-compilation-unit (:override t) - (let ((*deferred-warnings* ()) - #+sbcl (sb-c::*undefined-warnings* nil)) + (let (#+sbcl (sb-c::*undefined-warnings* nil)) (multiple-value-prog1 (with-muffled-compiler-conditions () (funcall thunk)) @@ -4500,7 +4524,7 @@ ,@(when (os-windows-p) `(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/") ,(subpathname* (get-folder-path :appdata) "common-lisp/config/"))) - ,(subpathname (user-homedir) ".config/common-lisp/")))) + ,(subpathname (user-homedir-pathname) ".config/common-lisp/")))) (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) :from-end t :test 'equal))) @@ -4678,12 +4702,13 @@ (return-from resolve-absolute-location (let ((p (make-pathname* :directory '(:relative)))) (if wilden (wilden p) p)))) - ((eql :home) (user-homedir)) + ((eql :home) (user-homedir-pathname)) ((eql :here) (resolve-absolute-location *here-directory* :ensure-directory t :wilden nil)) ((eql :user-cache) (resolve-absolute-location *user-cache* :ensure-directory t :wilden nil))) :wilden (and wilden (not (pathnamep x))) + :resolve-symlinks *resolve-symlinks* :want-absolute t)) ;; Try to override declaration in previous versions of ASDF. @@ -4691,21 +4716,21 @@ (:ensure-directory boolean)) t) resolve-location)) (defun* (resolve-location) (x &key ensure-directory wilden directory) - (when directory (setf ensure-directory t)) ;; :directory backward compatibility, until 2014-01-16. - (if (atom x) - (resolve-absolute-location x :ensure-directory ensure-directory :wilden wilden) - (loop* :with (first . rest) = x - :with path = (resolve-absolute-location - first :ensure-directory (and (or ensure-directory rest) t) - :wilden (and wilden (null rest))) - :for (element . morep) :on rest - :for dir = (and (or morep ensure-directory) t) - :for wild = (and wilden (not morep)) - :do (setf path (merge-pathnames* - (resolve-relative-location - element :ensure-directory dir :wilden wild) - path)) - :finally (return path)))) + ;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory + (loop* :with dirp = (or directory ensure-directory) + :with (first . rest) = (if (atom x) (list x) x) + :with path = (resolve-absolute-location + first :ensure-directory (and (or dirp rest) t) + :wilden (and wilden (null rest))) + :for (element . morep) :on rest + :for dir = (and (or morep dirp) t) + :for wild = (and wilden (not morep)) + :for sub = (merge-pathnames* + (resolve-relative-location + element :ensure-directory dir :wilden wild) + path) + :do (setf path (if (absolute-pathname-p sub) (resolve-symlinks* sub) sub)) + :finally (return path))) (defun* location-designator-p (x) (flet ((absolute-component-p (c) @@ -4790,7 +4815,7 @@ :asdf/package :asdf/utility :asdf/pathname :asdf/stream :asdf/os :asdf/image :asdf/run-program :asdf/lisp-build - :asdf/configuration)) + :asdf/configuration :asdf/backward-driver)) ;;;; ------------------------------------------------------------------------- ;;;; Handle upgrade as forward- and backward-compatibly as possible ;; See https://bugs.launchpad.net/asdf/+bug/485687 @@ -4828,7 +4853,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.26.143.1") + (asdf-version "2.26.158.1") (existing-asdf (find-class (find-symbol* :component :asdf nil) nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version)) @@ -4963,7 +4988,6 @@ #:component-if-feature #:around-compile-hook #:component-description #:component-long-description #:component-version #:version-satisfies - #:component-properties #:component-property ;; backward-compatibility only. DO NOT USE! #:component-inline-methods ;; backward-compatibility only. DO NOT USE! #:component-operation-times ;; For internal use only. ;; portable ASDF encoding and implementation-specific external-format @@ -4972,6 +4996,7 @@ #:component-build-operation #:module-default-component-class #:module-components ;; backward-compatibility. DO NOT USE. + #:sub-components ;; Internals we'd like to share with the ASDF package, especially for upgrade purposes #:name #:version #:description #:long-description #:author #:maintainer #:licence @@ -4995,9 +5020,6 @@ Despite the function's name, the return value may be an absolute pathname, because an absolute pathname may be interpreted relative to another pathname in a degenerate way.")) -(defgeneric* component-property (component property)) -#-gcl2.6 -(defgeneric* (setf component-property) (new-value component property)) (defgeneric* component-external-format (component)) (defgeneric* component-encoding (component)) (defgeneric* version-satisfies (component version)) @@ -5049,11 +5071,9 @@ (operation-times :initform (make-hash-table) :accessor component-operation-times) (around-compile :initarg :around-compile) + (properties) ;; Only for backward-compatibility during upgrades from ASDF2. DO NOT USE. (%encoding :accessor %component-encoding :initform nil :initarg :encoding) - ;; ASDF3: get rid of these "component properties" ? - (properties :accessor component-properties :initarg :properties - :initform nil) - ;; For backward-compatibility, this slot is part of component rather than child-component + ;; For backward-compatibility, this slot is part of component rather than child-component. ASDF4: don't. (parent :initarg :parent :initform nil :reader component-parent) (build-operation :initarg :build-operation :initform nil :reader component-build-operation))) @@ -5176,20 +5196,6 @@ (file-type component)) -;;;; General component-property - ASDF3: remove? Define clean subclasses, not messy "properties". - -(defmethod component-property ((c component) property) - (cdr (assoc property (slot-value c 'properties) :test #'equal))) - -(defmethod (setf component-property) (new-value (c component) property) - (let ((a (assoc property (slot-value c 'properties) :test #'equal))) - (if a - (setf (cdr a) new-value) - (setf (slot-value c 'properties) - (acons property new-value (slot-value c 'properties))))) - new-value) - - ;;;; Encodings (defmethod component-encoding ((c component)) @@ -5223,6 +5229,19 @@ (defmethod version-satisfies ((cver string) version) (version-compatible-p cver version)) + + +;;; all sub-components (of a given type) + +(defun* sub-components (component &key (type t)) + (while-collecting (c) + (labels ((recurse (x) + (when (if-let (it (component-if-feature x)) (featurep it) t) + (when (typep x type) + (c x)) + (when (typep x 'parent-component) + (map () #'recurse (component-children x)))))) + (recurse component)))) ;;;; ------------------------------------------------------------------------- ;;;; Systems @@ -5237,15 +5256,21 @@ #:system-author #:system-maintainer #:system-licence #:system-license #:system-defsystem-depends-on #:component-build-pathname #:build-pathname + #:component-entry-point #:entry-point #:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system (in-package :asdf/system) (defgeneric* (find-system) (system &optional error-p)) (defgeneric* (system-source-file) (system) (:documentation "Return the source file in which system is defined.")) -(defgeneric* builtin-system-p (system)) (defgeneric* component-build-pathname (component)) +(defgeneric* component-entry-point (component)) +(defmethod component-entry-point ((c component)) + (declare (ignorable c)) + nil) + + ;;;; The system class (defclass proto-system () ; slots to keep when resetting a system @@ -5254,7 +5279,7 @@ ((name) (source-file) #|(children) (children-by-names)|#)) (defclass system (module proto-system) - ;; Backward-compatibility: inherit from module. ASDF3: only inherit from parent-component. + ;; Backward-compatibility: inherit from module. ASDF4: only inherit from parent-component. (;; {,long-}description is now inherited from component, but we add the legacy accessors (description :accessor system-description) (long-description :accessor system-long-description) @@ -5262,8 +5287,11 @@ (maintainer :accessor system-maintainer :initarg :maintainer) (licence :accessor system-licence :initarg :licence :accessor system-license :initarg :license) + (builtin-system-p :accessor builtin-system-p :initform nil :initarg :builtin-system-p) (build-pathname :initform nil :initarg :build-pathname :accessor component-build-pathname) + (entry-point + :initform nil :initarg :entry-point :accessor component-entry-point) (source-file :initform nil :initarg :source-file :accessor system-source-file) (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) @@ -5307,23 +5335,74 @@ (declare (ignorable c)) nil) ;;;; ------------------------------------------------------------------------- +;;;; Stamp cache + +(asdf/package:define-package :asdf/cache + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade) + (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp + #:consult-asdf-cache #:do-asdf-cache + #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*)) +(in-package :asdf/cache) + +;;; This stamp cache is useful for: +;; * consistency of stamps used within a single run +;; * fewer accesses to the filesystem +;; * the ability to test with fake timestamps, without touching files + +(defvar *asdf-cache* nil) + +(defun set-asdf-cache-entry (key value-list) + (apply 'values + (if *asdf-cache* + (setf (gethash key *asdf-cache*) value-list) + value-list))) + +(defun consult-asdf-cache (key thunk) + (if *asdf-cache* + (multiple-value-bind (results foundp) (gethash key *asdf-cache*) + (if foundp + (apply 'values results) + (set-asdf-cache-entry key (multiple-value-list (funcall thunk))))) + (funcall thunk))) + +(defmacro do-asdf-cache (key &body body) + `(consult-asdf-cache ,key #'(lambda () , at body))) + +(defun call-with-asdf-cache (thunk &key override) + (if (and *asdf-cache* (not override)) + (funcall thunk) + (let ((*asdf-cache* (make-hash-table :test 'equal))) + (funcall thunk)))) + +(defmacro with-asdf-cache ((&key override) &body body) + `(call-with-asdf-cache #'(lambda () , at body) :override ,override)) + +(defun compute-file-stamp (file) + (safe-file-write-date file)) + +(defun register-file-stamp (file &optional (stamp (compute-file-stamp file))) + (set-asdf-cache-entry `(get-file-stamp ,file) (list stamp))) + +(defun get-file-stamp (file) + (do-asdf-cache `(get-file-stamp ,file) (compute-file-stamp file))) +;;;; ------------------------------------------------------------------------- ;;;; Finding systems (asdf/package:define-package :asdf/find-system (:recycle :asdf/find-system :asdf) (:use :asdf/common-lisp :asdf/driver :asdf/upgrade - :asdf/component :asdf/system) + :asdf/component :asdf/system :asdf/cache) (:export #:remove-entry-from-registry #:coerce-entry-to-directory #:coerce-name #:primary-system-name - #:find-system #:locate-system #:load-sysdef #:with-system-definitions + #:find-system #:locate-system #:load-asd #:with-system-definitions #:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems #:system-definition-error #:missing-component #:missing-requires #:missing-parent #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error #:load-system-definition-error #:error-name #:error-pathname #:error-condition #:*system-definition-search-functions* #:search-for-system-definition #:*central-registry* #:probe-asd #:sysdef-central-registry-search - #:make-temporary-package #:find-system-if-being-defined #:*systems-being-defined* + #:find-system-if-being-defined #:*systems-being-defined* #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed #:system-find-preloaded-system #:register-preloaded-system #:*preloaded-systems* #:make-defined-systems-table #:*defined-systems* @@ -5401,7 +5480,7 @@ (unless (eq system (cdr (gethash name *defined-systems*))) (setf (gethash name *defined-systems*) (cons (if-let (file (ignore-errors (system-source-file system))) - (safe-file-write-date file)) + (get-file-stamp file)) system))))) (defun* clear-system (name) @@ -5464,14 +5543,13 @@ (defun* probe-asd (name defaults &key truename) (block nil (when (directory-pathname-p defaults) - (let* ((file (probe-file* - (absolutize-pathnames - (list (make-pathname :name name :type "asd") - defaults *default-pathname-defaults* (getcwd)) - :resolve-symlinks truename) - :truename truename))) - (when file - (return file))) + (if-let (file (probe-file* + (ensure-pathname-absolute + (parse-unix-namestring name :type "asd") + #'(lambda () (ensure-pathname-absolute defaults 'get-pathname-defaults nil)) + nil) + :truename truename)) + (return file)) #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) (when (os-windows-p) (let ((shortcut @@ -5531,9 +5609,6 @@ (list new) (subseq *central-registry* (1+ position)))))))))) -(defun* make-temporary-package () - (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf/interface))) - (defmethod find-system ((name null) &optional (error-p t)) (declare (ignorable name)) (when error-p @@ -5551,33 +5626,29 @@ (defun* call-with-system-definitions (thunk) (if *systems-being-defined* - (funcall thunk) + (call-with-asdf-cache thunk) (let ((*systems-being-defined* (make-hash-table :test 'equal))) - (funcall thunk)))) + (call-with-asdf-cache thunk)))) (defmacro with-system-definitions ((&optional) &body body) `(call-with-system-definitions #'(lambda () , at body))) -(defun* load-sysdef (name pathname) +(defun* load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname)))) ;; Tries to load system definition with canonical NAME from PATHNAME. (with-system-definitions () - (let ((package (make-temporary-package))) ;; ASDF3: get rid of that. - (unwind-protect - (handler-bind - ((error #'(lambda (condition) - (error 'load-system-definition-error - :name name :pathname pathname - :condition condition)))) - (let ((*package* package) - (*default-pathname-defaults* - ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. - (pathname-directory-pathname (translate-logical-pathname pathname))) - (external-format (encoding-external-format (detect-encoding pathname)))) - (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") - pathname package) - (with-muffled-loader-conditions () - (load* pathname :external-format external-format)))) - (delete-package package))))) + (let ((*package* (find-package :asdf-user)) + (*default-pathname-defaults* + ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. + (pathname-directory-pathname (translate-logical-pathname pathname)))) + (handler-bind + ((error #'(lambda (condition) + (error 'load-system-definition-error + :name name :pathname pathname + :condition condition)))) + (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%") + name pathname) + (with-muffled-loader-conditions () + (load* pathname :external-format external-format)))))) (defun* locate-system (name) "Given a system NAME designator, try to locate where to load the system from. @@ -5624,15 +5695,15 @@ (pathname-equal (translate-logical-pathname pathname) (translate-logical-pathname previous-pathname)))) - (stamp<= (safe-file-write-date pathname) previous-time)))) + (stamp<= (get-file-stamp pathname) previous-time)))) ;; only load when it's a pathname that is different or has newer content - (load-sysdef name pathname))) + (load-asd pathname :name name))) (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed (return (cond (in-memory (when pathname - (setf (car in-memory) (safe-file-write-date pathname))) + (setf (car in-memory) (get-file-stamp pathname))) (cdr in-memory)) (error-p (error 'missing-component :requires name)))))) @@ -5655,22 +5726,6 @@ (register-preloaded-system "asdf") (register-preloaded-system "asdf-driver") -;;;; Beware of builtin systems -(defmethod builtin-system-p ((s system)) - (or - ;; For most purposes, asdf itself specially counts as builtin. - ;; if you want to link it or do something forbidden to builtins, - ;; specify separate dependencies on asdf-driver and asdf-defsystem. - (equal "asdf" (coerce-name s)) - ;; Other builtin systems are those under the implementation directory - (let* ((system (find-system s nil)) - (sysdir (and system (component-pathname system))) - (truesysdir (truename* sysdir)) - (impdir (lisp-implementation-directory)) - (trueimpdir (truename* impdir))) - (and sysdir impdir - (or (subpathp sysdir impdir) - (subpathp truesysdir trueimpdir)))))) ;;;; ------------------------------------------------------------------------- ;;;; Finding components @@ -5865,11 +5920,11 @@ (:nicknames :asdf-action) (:recycle :asdf/action :asdf) (:use :asdf/common-lisp :asdf/driver :asdf/upgrade - :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation) + :asdf/component :asdf/system #:asdf/cache :asdf/find-system :asdf/find-component :asdf/operation) (:intern #:stamp #:done-p) (:export #:action #:define-convenience-action-methods - #:explain #:operation-description + #:explain #:action-description #:downward-operation #:upward-operation #:sibling-operation #:component-depends-on #:component-self-dependencies #:input-files #:output-files #:output-file #:operation-done-p @@ -5877,8 +5932,7 @@ #:component-operation-time #:mark-operation-done #:compute-action-stamp #:perform #:perform-with-restarts #:retry #:accept #:feature #:traverse-actions #:traverse-sub-actions #:required-components ;; in plan - #:action-path #:find-action - )) + #:action-path #:find-action)) (in-package :asdf/action) (deftype action () '(cons operation component)) ;; a step to be performed while building the system @@ -5912,11 +5966,12 @@ (if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck. `(apply 'make-operation ,operation :original-initargs ,rest ,rest) `(make-operation ,operation)) - `(find-component () ,component)) + `(or (find-component () ,component) ,if-no-component)) ,if-no-operation)) (defmethod ,function ((,operation operation) ,component , at more-args) (if (typep ,component 'component) - (error "No defined method for ~S on ~S" ',function ,component) + (error "No defined method for ~S on ~/asdf-action:format-action/" + ',function (cons ,operation ,component)) (let ((,found (find-component () ,component))) (if ,found ,(next-method operation found) @@ -5925,27 +5980,27 @@ ;;;; self-description -(defgeneric* operation-description (operation component) ;; ASDF3: rename to action-description +(defgeneric* action-description (operation component) (:documentation "returns a phrase that describes performing this operation on this component, e.g. \"loading /a/b/c\". You can put together sentences using this phrase.")) -(defmethod operation-description (operation component) +(defmethod action-description (operation component) (format nil (compatfmt "~@<~A on ~A~@:>") (type-of operation) component)) (defgeneric* (explain) (operation component)) (defmethod explain ((o operation) (c component)) - (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (operation-description o c))) + (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c))) (define-convenience-action-methods explain (operation component)) (defun* format-action (stream action &optional colon-p at-sign-p) (assert (null colon-p)) (assert (null at-sign-p)) (destructuring-bind (operation . component) action - (princ (operation-description operation component) stream))) + (princ (action-description operation component) stream))) ;;;; Dependencies -(defgeneric* component-depends-on (operation component) ;; ASDF3: rename to component-dependencies +(defgeneric* component-depends-on (operation component) ;; ASDF4: rename to component-dependencies (:documentation "Returns a list of dependencies needed by the component to perform the operation. A dependency has one of the following forms: @@ -5992,7 +6047,7 @@ ((upward-operation :initform nil :initarg :downward-operation :reader upward-operation))) ;; For backward-compatibility reasons, a system inherits from module and is a child-component -;; so we must guard against this case. ASDF3: remove that. +;; so we must guard against this case. ASDF4: remove that. (defmethod component-depends-on ((o upward-operation) (c child-component)) `(,@(if-let (p (component-parent c)) `((,(or (upward-operation o) o) ,p))) ,@(call-next-method))) @@ -6023,22 +6078,23 @@ t) (defmethod output-files :around (operation component) - "Translate output files, unless asked not to" + "Translate output files, unless asked not to. Memoize the result." operation component ;; hush genera, not convinced by declare ignorable(!) - (values - (multiple-value-bind (pathnames fixedp) (call-next-method) - ;; 1- Make sure we have absolute pathnames - (let* ((directory (pathname-directory-pathname - (component-pathname (find-component () component)))) - (absolute-pathnames - (loop - :for pathname :in pathnames - :collect (ensure-pathname-absolute pathname directory)))) - ;; 2- Translate those pathnames as required - (if fixedp - absolute-pathnames - (mapcar *output-translation-function* absolute-pathnames)))) - t)) + (do-asdf-cache `(output-files ,operation ,component) + (values + (multiple-value-bind (pathnames fixedp) (call-next-method) + ;; 1- Make sure we have absolute pathnames + (let* ((directory (pathname-directory-pathname + (component-pathname (find-component () component)))) + (absolute-pathnames + (loop + :for pathname :in pathnames + :collect (ensure-pathname-absolute pathname directory)))) + ;; 2- Translate those pathnames as required + (if fixedp + absolute-pathnames + (mapcar *output-translation-function* absolute-pathnames)))) + t))) (defmethod output-files ((o operation) (c component)) (declare (ignorable o c)) nil) @@ -6048,6 +6104,11 @@ (assert (length=n-p files 1)) (first files))) +(defmethod input-files :around (operation component) + "memoize input files." + (do-asdf-cache `(input-files ,operation ,component) + (call-next-method))) + (defmethod input-files ((o operation) (c parent-component)) (declare (ignorable o c)) nil) @@ -6063,11 +6124,10 @@ ;;;; Done performing -(defgeneric* component-operation-time (operation component)) ;; ASDF3: hide it behind plan-action-stamp +(defgeneric* component-operation-time (operation component)) ;; ASDF4: hide it behind plan-action-stamp (define-convenience-action-methods component-operation-time (operation component)) - -(defgeneric* mark-operation-done (operation component)) ;; ASDF3: hide it behind (setf plan-action-stamp) +(defgeneric* mark-operation-done (operation component)) ;; ASDF4: hide it behind (setf plan-action-stamp) (defgeneric* compute-action-stamp (plan operation component &key just-done) (:documentation "Has this action been successfully done already, and at what known timestamp has it been done at or will it be done at? @@ -6137,12 +6197,12 @@ :report (lambda (s) (format s (compatfmt "~@") - (operation-description operation component)))) + (action-description operation component)))) (accept () :report (lambda (s) (format s (compatfmt "~@") - (operation-description operation component))) + (action-description operation component))) (mark-operation-done operation component) (return))))) @@ -6201,7 +6261,7 @@ ;;;; prepare-op, compile-op and load-op ;;; prepare-op -(defmethod operation-description ((o prepare-op) (c component)) +(defmethod action-description ((o prepare-op) (c component)) (declare (ignorable o)) (format nil (compatfmt "~@") c)) (defmethod perform ((o prepare-op) (c component)) @@ -6215,10 +6275,10 @@ (if-let (it (system-source-file s)) (list it))) ;;; compile-op -(defmethod operation-description ((o compile-op) (c component)) +(defmethod action-description ((o compile-op) (c component)) (declare (ignorable o)) (format nil (compatfmt "~@") c)) -(defmethod operation-description ((o compile-op) (c parent-component)) +(defmethod action-description ((o compile-op) (c parent-component)) (declare (ignorable o)) (format nil (compatfmt "~@") c)) (defgeneric* call-with-around-compile-hook (component thunk)) @@ -6297,13 +6357,13 @@ #+(or clozure sbcl) (defmethod input-files ((o compile-op) (c system)) (declare (ignorable o c)) - (unless (builtin-system-p c) - (loop* :for (sub-o . sub-c) - :in (traverse-sub-actions - o c :other-systems nil - :keep-operation 'compile-op :keep-component 'cl-source-file) - :append (remove-if-not 'warnings-file-p - (output-files sub-o sub-c))))) + (when *warnings-file-type* + (unless (builtin-system-p c) + ;; The most correct way to do it would be to use: + ;; (traverse-sub-actions o c :other-systems nil :keep-operation 'compile-op :keep-component 'cl-source-file) + ;; but it's expensive and we don't care too much about file order or ASDF extensions. + (loop :for sub :in (sub-components c :type 'cl-source-file) + :nconc (remove-if-not 'warnings-file-p (output-files o sub)))))) #+sbcl (defmethod output-files ((o compile-op) (c system)) (unless (builtin-system-p c) @@ -6311,13 +6371,13 @@ (list (subpathname pathname (component-name c) :type "build-report"))))) ;;; load-op -(defmethod operation-description ((o load-op) (c cl-source-file)) +(defmethod action-description ((o load-op) (c cl-source-file)) (declare (ignorable o)) (format nil (compatfmt "~@") c)) -(defmethod operation-description ((o load-op) (c parent-component)) +(defmethod action-description ((o load-op) (c parent-component)) (declare (ignorable o)) (format nil (compatfmt "~@") c)) -(defmethod operation-description ((o load-op) component) +(defmethod action-description ((o load-op) component) (declare (ignorable o)) (format nil (compatfmt "~@") component)) @@ -6349,7 +6409,7 @@ ;;;; prepare-source-op, load-source-op ;;; prepare-source-op -(defmethod operation-description ((o prepare-source-op) (c component)) +(defmethod action-description ((o prepare-source-op) (c component)) (declare (ignorable o)) (format nil (compatfmt "~@") c)) (defmethod input-files ((o prepare-source-op) (c component)) @@ -6363,10 +6423,10 @@ nil) ;;; load-source-op -(defmethod operation-description ((o load-source-op) c) +(defmethod action-description ((o load-source-op) c) (declare (ignorable o)) (format nil (compatfmt "~@") c)) -(defmethod operation-description ((o load-source-op) (c parent-component)) +(defmethod action-description ((o load-source-op) (c parent-component)) (declare (ignorable o)) (format nil (compatfmt "~@") c)) (defmethod component-depends-on ((o load-source-op) (c component)) @@ -6407,7 +6467,8 @@ (asdf/package:define-package :asdf/plan (:recycle :asdf/plan :asdf) (:use :asdf/common-lisp :asdf/driver :asdf/upgrade - :asdf/component :asdf/operation :asdf/system :asdf/find-system :asdf/find-component + :asdf/component :asdf/operation :asdf/system + :asdf/cache :asdf/find-system :asdf/find-component :asdf/operation :asdf/action) (:export #:component-operation-time #:mark-operation-done @@ -6599,7 +6660,7 @@ stamp) (defmethod compute-action-stamp (plan (o operation) (c component) &key just-done) - ;; In a distant future, safe-file-write-date and component-operation-time + ;; In a distant future, get-file-stamp and component-operation-time ;; shall also be parametrized by the plan, or by a second model object. (let* ((stamp-lookup #'(lambda (o c) (if-let (it (plan-action-status plan o c)) (action-stamp it) t))) @@ -6614,8 +6675,8 @@ ;; Accumulated timestamp from dependencies (or T if forced or out-of-date) (dep-stamp (visit-dependencies plan o c stamp-lookup)) ;; Time stamps from the files at hand, and whether any is missing - (out-stamps (mapcar #'safe-file-write-date out-files)) - (in-stamps (mapcar #'safe-file-write-date in-files)) + (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files)) + (in-stamps (mapcar #'get-file-stamp in-files)) (missing-in (loop :for f :in in-files :for s :in in-stamps :unless s :collect f)) (missing-out @@ -6632,7 +6693,7 @@ (when (and just-done (not all-present)) (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~ ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]" - (operation-description o c) + (action-description o c) missing-in (length missing-in) (and missing-in missing-out) missing-out (length missing-out))) ;; Note that we use stamp<= instead of stamp< to play nice with generated files. @@ -6779,12 +6840,16 @@ (traverse-action plan o c t) (plan-actions plan))) - -(defmethod perform-plan ((steps list) &key) +(defmethod perform-plan :around (plan &key) + (declare (ignorable plan)) (let ((*package* *package*) (*readtable* *readtable*)) - (loop* :for (op . component) :in steps :do - (perform-with-restarts op component)))) + (with-compilation-unit () ;; backward-compatibility. + (call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build. + +(defmethod perform-plan ((steps list) &key) + (loop* :for (op . component) :in steps :do + (perform-with-restarts op component))) (defmethod plan-operates-on-p ((plan list) (component-path list)) (find component-path (mapcar 'cdr plan) @@ -7031,6 +7096,7 @@ #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname #:environment-output-translations #:process-output-translations #:compute-output-translations + #+abcl #:translate-jar-pathname )) (in-package :asdf/output-translations) @@ -7485,11 +7551,11 @@ #+scl (:tree #p"file://modules/"))) (defun* default-source-registry () `(:source-registry - #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/")) + #+sbcl (:directory ,(subpathname (user-homedir-pathname) ".sbcl/systems/")) ,@(loop :for dir :in `(,@(when (os-unix-p) `(,(or (getenv-absolute-directory "XDG_DATA_HOME") - (subpathname (user-homedir) ".local/share/")) + (subpathname (user-homedir-pathname) ".local/share/")) ,@(or (getenv-absolute-directories "XDG_DATA_DIRS") '("/usr/local/share" "/usr/share")))) ,@(when (os-windows-p) @@ -7641,11 +7707,14 @@ (asdf/package:define-package :asdf/backward-internals (:recycle :asdf/backward-internals :asdf) (:use :asdf/common-lisp :asdf/driver :asdf/upgrade - :asdf/system :asdf/component :asdf/find-system :asdf/action) + :asdf/system :asdf/component :asdf/operation + :asdf/find-system :asdf/action :asdf/lisp-action) (:export ;; for internal use + #:load-sysdef #:make-temporary-package #:%refresh-component-inline-methods #:%resolve-if-component-dep-fails - #:make-sub-operation)) + #:make-sub-operation + #:load-sysdef #:make-temporary-package)) (in-package :asdf/backward-internals) ;;;; Backward compatibility with "inline methods" @@ -7691,13 +7760,13 @@ (defun* %resolve-if-component-dep-fails (if-component-dep-fails component) (asdf-message "The system definition for ~S uses deprecated ~ ASDF option :IF-COMPONENT-DEP-DAILS. ~ - Starting with ASDF 2.27, please use :IF-FEATURE instead" + Starting with ASDF 3, please use :IF-FEATURE instead" (coerce-name (component-system component))) ;; This only supports the pattern of use of the "feature" seen in the wild (check-type component parent-component) (check-type if-component-dep-fails (member :fail :ignore :try-next)) (unless (eq if-component-dep-fails :fail) - (loop :with o = (make-instance 'compile-op) + (loop :with o = (make-operation 'compile-op) :for c :in (component-children component) :do (loop* :for (feature? feature) :in (component-depends-on o c) :when (eq feature? 'feature) :do @@ -7706,13 +7775,23 @@ (when-upgrade (:when (fboundp 'make-sub-operation)) (defun* make-sub-operation (c o dep-c dep-o) (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error))) + + +;;;; load-sysdef +(defun* load-sysdef (name pathname) + (load-asd pathname :name name)) + +(defun* make-temporary-package () + (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf/interface))) + + ;;;; ------------------------------------------------------------------------- ;;;; Defsystem (asdf/package:define-package :asdf/defsystem (:recycle :asdf/defsystem :asdf) (:use :asdf/common-lisp :asdf/driver :asdf/upgrade - :asdf/component :asdf/system + :asdf/component :asdf/system :asdf/cache :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate :asdf/backward-internals) (:export @@ -7739,13 +7818,12 @@ ;; and may be from within the EVAL-WHEN of a file compilation. ;; If no absolute pathname was found, we return NIL. (check-type pathname (or null string pathname)) - (let ((pathname (parse-unix-namestring pathname :type :directory)) - (load-pathname (load-pathname))) - (when (or pathname load-pathname) - (pathname-directory-pathname - (absolutize-pathnames - (list pathname load-pathname *default-pathname-defaults* (getcwd)) - :resolve-symlinks *resolve-symlinks*))))) + (resolve-symlinks* + (ensure-pathname-absolute + (parse-unix-namestring pathname :type :directory) + #'(lambda () (ensure-pathname-absolute + (load-pathname) 'get-pathname-defaults nil)) + nil))) ;;; Component class @@ -7810,6 +7888,7 @@ (defun* parse-component-form (parent options &key previous-serial-component) (destructuring-bind (type name &rest rest &key + (builtin-system-p () bspp) ;; the following list of keywords is reproduced below in the ;; remove-plist-keys form. important to keep them in sync components pathname perform explain output-files operation-done-p @@ -7817,7 +7896,7 @@ do-first if-component-dep-fails (version nil versionp) ;; list ends &allow-other-keys) options - (declare (ignorable perform explain output-files operation-done-p)) + (declare (ignorable perform explain output-files operation-done-p builtin-system-p)) (check-component-input type name weakly-depends-on depends-on components) (when (and parent (find-component parent name) @@ -7825,7 +7904,7 @@ (typep (find-component parent name) (class-for-type parent type)))) (error 'duplicate-names :name name)) - (when do-first (error "DO-FIRST is not supported anymore as of ASDF 2.27")) + (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3")) (let* ((args `(:name ,(coerce-name name) :pathname ,pathname ,@(when parent `(:parent ,parent)) @@ -7836,7 +7915,7 @@ rest))) (component (find-component parent name))) (when weakly-depends-on - ;; ASDF3: deprecate this feature and remove it. + ;; ASDF4: deprecate this feature and remove it. (appendf depends-on (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on))) (when previous-serial-component @@ -7846,6 +7925,8 @@ (setf component (apply 'make-instance (class-for-type parent type) args))) (component-pathname component) ; eagerly compute the absolute pathname (let ((sysdir (system-source-directory (component-system component)))) ;; requires the previous + (when (and (typep component 'system) (not bspp)) + (setf (builtin-system-p component) (lisp-implementation-pathname-p sysdir))) (setf version (normalize-version version sysdir))) (when (and versionp version (not (parse-version version nil))) (warn (compatfmt "~@") @@ -7862,7 +7943,7 @@ :collect c :when serial :do (setf previous-component name))) (compute-children-by-name component)) - ;; Used by POIU. ASDF3: rename to component-depends-on + ;; Used by POIU. ASDF4: rename to component-depends-on? (setf (component-sibling-dependencies component) depends-on) (%refresh-component-inline-methods component rest) (when if-component-dep-fails @@ -7883,7 +7964,7 @@ (source-file (if sfp source-file (resolve-symlinks* (load-pathname)))) (registered (system-registered-p name)) (registered! (if registered - (rplaca registered (safe-file-write-date source-file)) + (rplaca registered (get-file-stamp source-file)) (register-system (make-instance 'system :name name :source-file source-file)))) (system (reset-system (cdr registered!) @@ -7922,8 +8003,7 @@ #:user-system-p #:user-system #:trivial-system-p #+ecl #:make-build #:register-pre-built-system - #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library - #:component-entry-point #:entry-point)) + #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library)) (in-package :asdf/bundle) (defclass bundle-op (operation) @@ -7982,16 +8062,6 @@ ;; All: create an executable file from the system and its dependencies ((bundle-type :initform :program))) -(defgeneric* component-entry-point (component)) - -(defmethod component-entry-point ((c component)) - (declare (ignorable c)) - nil) - -(defclass bundle-system (system) - ((entry-point - :initform nil :initarg :entry-point :accessor component-entry-point))) - (defun* bundle-pathname-type (bundle-type) (etypecase bundle-type ((eql :no-output-file) nil) ;; should we error out instead? @@ -8487,7 +8557,7 @@ (asdf/package:define-package :asdf/backward-interface (:recycle :asdf/backward-interface :asdf) (:use :asdf/common-lisp :asdf/driver :asdf/upgrade - :asdf/component :asdf/system :asdf/operation :asdf/action + :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action :asdf/lisp-build :asdf/operate :asdf/output-translations) (:export #:*asdf-verbose* @@ -8553,21 +8623,26 @@ (&key (centralize-lisp-binaries nil) (default-toplevel-directory - (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ??? + (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ??? (include-per-user-information nil) (map-all-source-files (or #+(or clisp ecl mkcl) t nil)) - (source-to-target-mappings nil)) + (source-to-target-mappings nil) + (file-types (list (compile-file-type) + #+ecl (compile-file-type :type :object) + #+mkcl (compile-file-type :fasl-p nil) + #+clisp "lib" #+sbcl "cfasl" + #+sbcl "sbcl-warnings" #+clozure "ccl-warnings"))) #+(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 CLISP, ECL and MKCL")) - (let* ((fasl-type (compile-file-type)) - (mapped-files (if map-all-source-files *wild-file* - (make-pathname :type fasl-type :defaults *wild-file*))) + (let* ((patterns (if map-all-source-files (list *wild-file*) + (loop :for type :in file-types + :collect (make-pathname :type type :defaults *wild-file*)))) (destination-directory (if centralize-lisp-binaries `(,default-toplevel-directory ,@(when include-per-user-information - (cdr (pathname-directory (user-homedir)))) + (cdr (pathname-directory (user-homedir-pathname)))) :implementation ,*wild-inferiors*) `(:root ,*wild-inferiors* :implementation)))) (initialize-output-translations @@ -8575,8 +8650,9 @@ , at source-to-target-mappings #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) #+abcl (#p"/___jar___file___root___/**/*.*" (, at destination-directory)) - ((:root ,*wild-inferiors* ,mapped-files) - (, at destination-directory ,mapped-files)) + ,@(loop :for pattern :in patterns + :collect `((:root ,*wild-inferiors* ,pattern) + (, at destination-directory ,pattern))) (t t) :ignore-inherited-configuration)))) @@ -8609,6 +8685,7 @@ (let ((command (apply 'format nil control-string args))) (asdf-message "; $ ~A~%" command) (run-program command :force-shell t :ignore-error-status t :output *verbose-out*))) + ;;;; --------------------------------------------------------------------------- ;;;; Handle ASDF package upgrade, including implementation-dependent magic. @@ -8621,7 +8698,7 @@ #:split #:make-collector #:loaded-systems ; makes for annoying SLIME completion #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/cache :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action :asdf/output-translations :asdf/source-registry @@ -8642,7 +8719,7 @@ #:feature #:version #:version-satisfies #:upgrade-asdf #:implementation-identifier #:implementation-type #:hostname #:input-files #:output-files #:output-file #:perform - #:operation-done-p #:explain #:component-sibling-dependencies + #:operation-done-p #:explain #:action-description #:component-sibling-dependencies #:needed-in-image-p ;; #:run-program ; we can't export it, because SB-GROVEL :use's both ASDF and SB-EXT. #:component-load-dependencies #:run-shell-command ; deprecated, do not use @@ -8672,7 +8749,6 @@ #:component-name #:component-version #:component-parent - #:component-property #:component-system #:component-encoding #:component-external-format @@ -8692,8 +8768,6 @@ #:system-relative-pathname #:map-systems - #:operation-description - #:*system-definition-search-functions* ; variables #:*central-registry* #:*compile-file-warnings-behaviour* @@ -8705,7 +8779,9 @@ #:asdf-version - #:operation-error #:compile-failed #:compile-warned #:compile-error + #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error + #:compile-warned-warning #:compile-failed-warning + #:operation-error #:compile-failed #:compile-warned #:compile-error ;; backward compatibility #:error-name #:error-pathname #:load-system-definition-error @@ -8738,6 +8814,7 @@ #:apply-output-translations #:compile-file* #:compile-file-pathname* + #:*warnings-file-type* #:enable-asdf-binary-locations-compatibility #:*default-source-registries* #:*source-registry-parameter* @@ -8758,6 +8835,12 @@ #:user-source-registry-directory #:system-source-registry-directory)) +;;;; --------------------------------------------------------------------------- +;;;; ASDF-USER, where the action happens. + +(asdf/package:define-package :asdf/user + (:nicknames :asdf-user) + (:use :asdf/common-lisp :asdf/package :asdf/interface)) ;;;; ----------------------------------------------------------------------- ;;;; ASDF Footer: last words and cleanup @@ -8770,22 +8853,17 @@ :asdf/backward-internals :asdf/defsystem :asdf/backward-interface)) (in-package :asdf/footer) -;;;; Configure -(setf asdf/utility:*asdf-debug-utility* - '(asdf/system:system-relative-pathname :asdf "contrib/debug.lisp")) - ;;;; Hook ASDF into the implementation's REQUIRE and other entry points. #+(or abcl clisp clozure cmu ecl mkcl sbcl) -(let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil)))) - (when x - (eval `(pushnew 'module-provide-asdf - #+abcl sys::*module-provider-functions* - #+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*)))) +(if-let (x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil))) + (eval `(pushnew 'module-provide-asdf + #+abcl sys::*module-provider-functions* + #+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*))) #+(or ecl mkcl) (progn @@ -8821,7 +8899,7 @@ (when (boundp 'excl:*warn-on-nested-reader-conditionals*) (setf excl:*warn-on-nested-reader-conditionals* asdf/common-lisp::*acl-warn-save*))) -(dolist (f '(:asdf :asdf2 :asdf2.27)) (pushnew f *features*)) +(dolist (f '(:asdf :asdf2 :asdf3)) (pushnew f *features*)) (provide :asdf) From mevenson at common-lisp.net Tue Jan 29 08:36:17 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 29 Jan 2013 00:36:17 -0800 Subject: [armedbear-cvs] r14363 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Jan 29 00:36:14 2013 New Revision: 14363 Log: Add a constructor to allow MemoryClassLoader to specify a parent. Needed to allow the code in http://paste.lisp.org/display/134966 to work. Patch by Milos Negovanovic. Modified: trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Modified: trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java Mon Jan 28 05:24:57 2013 (r14362) +++ trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java Tue Jan 29 00:36:14 2013 (r14363) @@ -123,6 +123,10 @@ public JavaClassLoader(ClassLoader parent) { super(new URL[] {}, parent); } + + public JavaClassLoader(JavaClassLoader parent) { + super(new URL[] {}, (ClassLoader)parent); + } public JavaClassLoader(URL[] classpath, ClassLoader parent) { super(classpath, parent); Modified: trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java Mon Jan 28 05:24:57 2013 (r14362) +++ trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java Tue Jan 29 00:36:14 2013 (r14363) @@ -52,6 +52,11 @@ this.internalNamePrefix = internalNamePrefix; } + public MemoryClassLoader(JavaClassLoader parent) { + super(parent); + this.internalNamePrefix = ""; + } + @Override protected Class loadClass(String name, boolean resolve) throws ClassNotFoundException { Modified: trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Mon Jan 28 05:24:57 2013 (r14362) +++ trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Tue Jan 29 00:36:14 2013 (r14363) @@ -35,9 +35,9 @@ Field definitions are lists of the form (field-name type &key modifiers annotations)." (declare (ignorable superclass interfaces constructors methods fields access-flags annotations)) - (let ((stream (sys::%make-byte-array-output-stream)) - ;;TODO provide constructor in MemoryClassLoader - (memory-class-loader (java:jnew "org.armedbear.lisp.MemoryClassLoader" ""))) + (let* ((stream (sys::%make-byte-array-output-stream)) + (current-class-loader (java:get-current-classloader)) + (memory-class-loader (java:jnew "org.armedbear.lisp.MemoryClassLoader" current-class-loader))) (multiple-value-bind (class-file method-implementation-fields) (apply #'java::%jnew-runtime-class class-name stream args) (sys::put-memory-function memory-class-loader @@ -297,4 +297,4 @@ (list "bar" :int '("java.lang.Object") (lambda (this that) (print (list this that)) 23)))) -(provide "RUNTIME-CLASS") \ No newline at end of file +(provide "RUNTIME-CLASS") From mevenson at common-lisp.net Thu Jan 31 10:02:35 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 31 Jan 2013 02:02:35 -0800 Subject: [armedbear-cvs] r14364 - in trunk/abcl/contrib/abcl-asdf: . tests Message-ID: Author: mevenson Date: Thu Jan 31 02:02:29 2013 New Revision: 14364 Log: ASDF systems using the MVN component now load again. log4j.asd example corrected as well. FIND-MVN now emits a warning if it cannot actually find a Maven exectuable. Thanks to Milos Negovanovic for identifying the problem with a patch. Fixes #299. Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp trunk/abcl/contrib/abcl-asdf/tests/example.lisp trunk/abcl/contrib/abcl-asdf/tests/log4j.asd Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Tue Jan 29 00:36:14 2013 (r14363) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Thu Jan 31 02:02:29 2013 (r14364) @@ -131,13 +131,13 @@ (java:java-exception (e) (unless (java:jinstance-of-p (java:java-exception-cause e) "java.lang.ClassNotFoundException") - (error "Unexpected Java exception~&~A.~&" e)) - (if (find-mvn) - (resolve-dependencies group-id artifact-id version) - (if alternate-uri - (values (namestring alternate-uri) alternate-uri) - (t - (error "Failed to resolve MVN component name ~A." name))))))))) + (error "Unexpected Java exception~&~A.~&" e)))) + (if (find-mvn) + (resolve-dependencies group-id artifact-id version) + (if alternate-uri + (values (namestring alternate-uri) alternate-uri) + (t + (error "Failed to resolve MVN component name ~A." name))))))) (defun as-classpath (classpath) "Break apart the JVM CLASSPATH string into a list of its consituents." Modified: trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Tue Jan 29 00:36:14 2013 (r14363) +++ trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Thu Jan 31 02:02:29 2013 (r14364) @@ -50,7 +50,9 @@ (defun find-mvn () "Attempt to find a suitable Maven ('mvn') executable on the hosting operating system. -Returns the path of the Maven executable or nil if none are found." +Returns the path of the Maven executable or nil if none are found. + +Emits warnings if not able to find a suitable executable." (let ((m2-home (ext:getenv "M2_HOME")) (m2 (ext:getenv "M2")) @@ -97,7 +99,8 @@ "~&Failed to find Maven executable '~A' in PATH because~&~A" mvn-path e))))) (when mvn - (return-from find-mvn mvn)))))))) + (return-from find-mvn mvn))))))) + (warn "Unable to locate Maven executable.")) (defun find-mvn-libs () (let ((mvn (find-mvn))) Modified: trunk/abcl/contrib/abcl-asdf/tests/example.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/tests/example.lisp Tue Jan 29 00:36:14 2013 (r14363) +++ trunk/abcl/contrib/abcl-asdf/tests/example.lisp Thu Jan 31 02:02:29 2013 (r14364) @@ -1,12 +1,14 @@ -(in-package :abcl-asdf-test) +(in-package :cl-user) -;;;(deftest LOG4J.2 -;;; (progn (defun test-LOG4J.2 () - (asdf:load-system "log4j") - (let ((logger (#"getLogger" 'log4j.Logger (symbol-name (gensym))))) - (#"trace" logger "Kilroy wuz here."))) -;;; t) + "Output a message to the Console. + +Note: for users of SLIME, this will appear in the associated *inferior-lisp* buffer." + (#"configure" 'log4j.BasicConfigurator) + (#"info" (#"getRootLogger" 'log4j.Logger) "Kilroy wuz here.")) + + + Modified: trunk/abcl/contrib/abcl-asdf/tests/log4j.asd ============================================================================== --- trunk/abcl/contrib/abcl-asdf/tests/log4j.asd Tue Jan 29 00:36:14 2013 (r14363) +++ trunk/abcl/contrib/abcl-asdf/tests/log4j.asd Thu Jan 31 02:02:29 2013 (r14364) @@ -1,12 +1,13 @@ ;;;; -*- Mode: LISP -*- -(in-package :asdf) -(defsystem :log4j - :components - ((:module log4j.jar :components +(asdf:defsystem :log4j + :defsystem-depends-on (abcl-asdf) + :components ((:module log4j.jar :components ((:mvn "log4j/log4j/1.2.15"))) (:module source :pathname "" :components ((:file "example")) :depends-on (log4j.jar)))) - +(defmethod perform ((o asdf:test-op) (s (eql (asdf:find-system :log4j)))) + (asdf:load-system :log4j) + (eval (read-from-string "(cl-user::test-log4j.2)"))) From mevenson at common-lisp.net Thu Jan 31 14:26:43 2013 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 31 Jan 2013 06:26:43 -0800 Subject: [armedbear-cvs] r14365 - trunk/abcl/contrib/abcl-asdf Message-ID: Author: mevenson Date: Thu Jan 31 06:26:25 2013 New Revision: 14365 Log: abcl-asdf: fix bug to use the version of specified MVN components. Reformat to SLIME whitespace conventions. Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Thu Jan 31 02:02:29 2013 (r14364) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Thu Jan 31 06:26:25 2013 (r14365) @@ -17,8 +17,8 @@ (repository :initform "http://repo1.maven.org/maven2/") ;;; XXX unimplmented (classname :initarg :classname :initform nil) (alternate-uri :initarg :alternate-uri :initform nil) -;; inherited from ASDF:COMPONENT ??? what are the CL semantics on overriding -- ME 2012-04-01 -#+nil (version :initform nil))) + ;; inherited from ASDF:COMPONENT ??? what are the CL semantics on overriding -- ME 2012-04-01 + #+nil (version :initform nil))) #+nil (defmethod find-component ((component iri) path) @@ -29,7 +29,7 @@ (defmethod perform ((op compile-op) (c mvn)) (abcl-asdf:resolve (ensure-parsed-mvn c))) - + (defmethod perform ((operation load-op) (c mvn)) (let ((resolved-path (abcl-asdf:resolve (ensure-parsed-mvn c)))) @@ -58,7 +58,7 @@ (defun ensure-parsed-mvn (component) (with-slots (name group-id artifact-id - version schema path repository) + version schema path repository) component (when (null asdf::artifact-id) (let ((parsed (abcl-asdf::split-string name "/")) @@ -97,7 +97,7 @@ (in-package #:abcl-asdf) (defgeneric resolve (something) - (:documentation "Returns a string in JVM CLASSPATH format as entries delimited by classpath separator string.")) + (:documentation "Returns a string in JVM CLASSPATH format as entries delimited by classpath separator string.")) (defmethod resolve ((mvn-component asdf::mvn)) "Resolve all runtime dependencies of MVN-COMPONENT. @@ -106,39 +106,31 @@ by classpath separator string or T. If the value T is returned, it denotes that current JVM already has already loaded a given class. Can possibly be a single entry denoting a remote binary artifact." - (macrolet ((aif (something consequence alternative)) - `(let ((it ,(something))) - (if it - consequence - alternative))) - (let ((name (slot-value mvn-component 'asdf::name)) - (group-id (slot-value mvn-component 'asdf::group-id)) - (artifact-id (slot-value mvn-component 'asdf::artifact-id)) - (classname (slot-value mvn-component 'asdf::classname)) - (alternate-uri (slot-value mvn-component 'asdf::alternate-uri)) - (version (let ((it (slot-value mvn-component 'asdf::version))) - (cond - ((not it) - it) - (t - "LATEST"))))) - (handler-case - (when (and classname - (jss:find-java-class classname)) - (warn "Not loading ~A from the network because ~A is present in classpath." - name classname) - (return-from resolve t)) - (java:java-exception (e) - (unless (java:jinstance-of-p (java:java-exception-cause e) - "java.lang.ClassNotFoundException") - (error "Unexpected Java exception~&~A.~&" e)))) - (if (find-mvn) - (resolve-dependencies group-id artifact-id version) - (if alternate-uri - (values (namestring alternate-uri) alternate-uri) - (t - (error "Failed to resolve MVN component name ~A." name))))))) - + (let ((name (slot-value mvn-component 'asdf::name)) + (group-id (slot-value mvn-component 'asdf::group-id)) + (artifact-id (slot-value mvn-component 'asdf::artifact-id)) + (classname (slot-value mvn-component 'asdf::classname)) + (alternate-uri (slot-value mvn-component 'asdf::alternate-uri)) + (version (if (slot-value mvn-component 'asdf::version) + (slot-value mvn-component 'asdf::version) + "LATEST"))) + (handler-case + (when (and classname + (jss:find-java-class classname)) + (warn "Not loading ~A from the network because ~A is present in classpath." + name classname) + (return-from resolve t)) + (java:java-exception (e) + (unless (java:jinstance-of-p (java:java-exception-cause e) + "java.lang.ClassNotFoundException") + (error "Unexpected Java exception~&~A.~&" e)))) + (if (find-mvn) + (resolve-dependencies group-id artifact-id version) + (if alternate-uri + (values (namestring alternate-uri) alternate-uri) + (t + (error "Failed to resolve MVN component name ~A." name)))))) + (defun as-classpath (classpath) "Break apart the JVM CLASSPATH string into a list of its consituents." (split-string classpath