From ehuelsmann at common-lisp.net Fri Oct 1 08:24:43 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 01 Oct 2010 04:24:43 -0400 Subject: [armedbear-cvs] r12932 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Oct 1 04:24:41 2010 New Revision: 12932 Log: Fix #88: "We need SYS:COMPILED-LISP-FUNCTION-P" to distinguish Java-defined and Lisp-defined functions (for SLIME). Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Fri Oct 1 04:24:41 2010 @@ -199,6 +199,21 @@ } }; + // ### compiled-lisp-function-p + private static final Primitive COMPILED_LISP_FUNCTION_P = + new pf_compiled_lisp_function_p(); + private static final class pf_compiled_lisp_function_p extends Primitive { + pf_compiled_lisp_function_p() { + super(Symbol.COMPILED_LISP_FUNCTION_P, "object"); + } + + @Override + public LispObject execute(LispObject arg) { + return (arg instanceof CompiledClosure + || arg instanceof CompiledPrimitive) ? T : NIL; + } + } + // ### consp private static final Primitive CONSP = new pf_consp(); private static final class pf_consp extends Primitive { Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Oct 1 04:24:41 2010 @@ -2986,6 +2986,8 @@ PACKAGE_SYS.addExternalSymbol("CLASS-BYTES"); public static final Symbol _CLASS_SLOTS = PACKAGE_SYS.addExternalSymbol("%CLASS-SLOTS"); + public static final Symbol COMPILED_LISP_FUNCTION_P = + PACKAGE_SYS.addExternalSymbol("COMPILED-LISP-FUNCTION-P"); public static final Symbol LAYOUT = PACKAGE_SYS.addExternalSymbol("LAYOUT"); public static final Symbol NAMED_LAMBDA = Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Oct 1 04:24:41 2010 @@ -808,7 +808,7 @@ (*code* ()) (*current-code-attribute* code)) (setf (code-max-locals code) 1) - (unless (eq super +lisp-primitive+) + (unless (eq super +lisp-compiled-primitive+) (multiple-value-bind (req opt key key-p rest allow-other-keys-p) @@ -876,7 +876,7 @@ (list +lisp-symbol+ +lisp-symbol+ +lisp-object+ +lisp-object+)))))) (aload 0) ;; this - (cond ((eq super +lisp-primitive+) + (cond ((eq super +lisp-compiled-primitive+) (emit-constructor-lambda-name lambda-name) (emit-constructor-lambda-list args) (emit-invokespecial-init super (lisp-object-arg-types 2))) @@ -7050,7 +7050,7 @@ (if (or *hairy-arglist-p* (and *child-p* *closure-variables*)) +lisp-compiled-closure+ - +lisp-primitive+)) + +lisp-compiled-primitive+)) (setf (abcl-class-file-lambda-list class-file) args) (setf (code-max-locals code) *registers-allocated*) Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Fri Oct 1 04:24:41 2010 @@ -167,6 +167,8 @@ (define-class-name +lisp-return+ "org.armedbear.lisp.Return") (define-class-name +lisp-go+ "org.armedbear.lisp.Go") (define-class-name +lisp-primitive+ "org.armedbear.lisp.Primitive") +(define-class-name +lisp-compiled-primitive+ + "org.armedbear.lisp.CompiledPrimitive") (define-class-name +lisp-eql-hash-table+ "org.armedbear.lisp.EqlHashTable") (define-class-name +lisp-hash-table+ "org.armedbear.lisp.HashTable") (define-class-name +lisp-package+ "org.armedbear.lisp.Package") From ehuelsmann at common-lisp.net Fri Oct 1 21:22:12 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 01 Oct 2010 17:22:12 -0400 Subject: [armedbear-cvs] r12933 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Oct 1 17:22:10 2010 New Revision: 12933 Log: Fix #106: DEFSTRUCT :include with :conc-name. Modified: trunk/abcl/src/org/armedbear/lisp/defstruct.lisp Modified: trunk/abcl/src/org/armedbear/lisp/defstruct.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/defstruct.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/defstruct.lisp Fri Oct 1 17:22:10 2010 @@ -49,6 +49,7 @@ (defmacro dd-print-object (x) `(aref ,x 11)) (defmacro dd-direct-slots (x) `(aref ,x 12)) (defmacro dd-slots (x) `(aref ,x 13)) +(defmacro dd-inherited-accessors (x) `(aref ,x 14)) (defun make-defstruct-description (&key name conc-name @@ -63,8 +64,9 @@ print-function print-object direct-slots - slots) - (let ((dd (make-array 14))) + slots + inherited-accessors) + (let ((dd (make-array 15))) (setf (dd-name dd) name (dd-conc-name dd) conc-name (dd-default-constructor dd) default-constructor @@ -78,7 +80,8 @@ (dd-print-function dd) print-function (dd-print-object dd) print-object (dd-direct-slots dd) direct-slots - (dd-slots dd) slots) + (dd-slots dd) slots + (dd-inherited-accessors dd) inherited-accessors) dd)) ;;; DEFSTRUCT-SLOT-DESCRIPTION @@ -121,6 +124,7 @@ (defvar *dd-print-object*) (defvar *dd-direct-slots*) (defvar *dd-slots*) +(defvar *dd-inherited-accessors*) (defun keywordify (symbol) (intern (symbol-name symbol) +keyword-package+)) @@ -326,11 +330,7 @@ (simple-typep object ',*dd-name*)))))))) (defun define-reader (slot) - (let ((accessor-name (if *dd-conc-name* - (intern (concatenate 'string - (symbol-name *dd-conc-name*) - (symbol-name (dsd-name slot)))) - (dsd-name slot))) + (let ((accessor-name (dsd-reader slot)) (index (dsd-index slot)) (type (dsd-type slot))) (cond ((eq *dd-type* 'list) @@ -353,11 +353,7 @@ (structure-ref (the ,',*dd-name* ,instance) ,,index))))))))) (defun define-writer (slot) - (let ((accessor-name (if *dd-conc-name* - (intern (concatenate 'string - (symbol-name *dd-conc-name*) - (symbol-name (dsd-name slot)))) - (dsd-name slot))) + (let ((accessor-name (dsd-reader slot)) (index (dsd-index slot))) (cond ((eq *dd-type* 'list) `((defun (setf ,accessor-name) (value instance) @@ -378,9 +374,11 @@ (defun define-access-functions () (let ((result ())) (dolist (slot *dd-slots*) - (setf result (nconc result (define-reader slot))) - (unless (dsd-read-only slot) - (setf result (nconc result (define-writer slot))))) + (let ((accessor-name (dsd-reader slot))) + (unless (assoc accessor-name *dd-inherited-accessors*) + (setf result (nconc result (define-reader slot))) + (unless (dsd-read-only slot) + (setf result (nconc result (define-writer slot))))))) result)) (defun define-copier () @@ -476,7 +474,8 @@ print-function print-object direct-slots - slots) + slots + inherited-accessors) (setf (get name 'structure-definition) (make-defstruct-description :name name :conc-name conc-name @@ -491,7 +490,8 @@ :print-function print-function :print-object print-object :direct-slots direct-slots - :slots slots)) + :slots slots + :inherited-accessors inherited-accessors)) (when (or (null type) named) (make-structure-class name direct-slots slots (car include))) (when default-constructor @@ -512,7 +512,8 @@ (*dd-print-function* nil) (*dd-print-object* nil) (*dd-direct-slots* ()) - (*dd-slots* ())) + (*dd-slots* ()) + (*dd-inherited-accessors* ())) (parse-name-and-options (if (atom name-and-options) (list name-and-options) name-and-options)) @@ -556,9 +557,19 @@ (dolist (dsd (dd-slots dd)) ;; MUST COPY SLOT DESCRIPTION! (setf dsd (copy-seq dsd)) - (setf (dsd-index dsd) index) + (setf (dsd-index dsd) index + (dsd-reader dsd) + (if *dd-conc-name* + (intern (concatenate 'string + (symbol-name *dd-conc-name*) + (symbol-name (dsd-name dsd)))) + (dsd-name dsd))) (push dsd *dd-slots*) - (incf index))) + (incf index)) + (setf *dd-inherited-accessors* (dd-inherited-accessors dd)) + (dolist (dsd (dd-direct-slots dd)) + (push (cons (dsd-reader dsd) (dsd-name dsd)) + *dd-inherited-accessors*))) (when (cdr *dd-include*) (dolist (slot (cdr *dd-include*)) (let* ((name (if (atom slot) slot (car slot))) @@ -605,7 +616,8 @@ ,@(if *dd-print-function* `(:print-function ',*dd-print-function*)) ,@(if *dd-print-object* `(:print-object ',*dd-print-object*)) :direct-slots ',*dd-direct-slots* - :slots ',*dd-slots*)) + :slots ',*dd-slots* + :inherited-accessors ',*dd-inherited-accessors*)) ,@(define-constructors) ,@(define-predicate) ,@(define-access-functions) From ehuelsmann at common-lisp.net Fri Oct 1 21:40:51 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 01 Oct 2010 17:40:51 -0400 Subject: [armedbear-cvs] r12934 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Oct 1 17:40:50 2010 New Revision: 12934 Log: Fix #97: Symbol imported into/exported from multiple packages reported multiple times by APROPOS. Modified: trunk/abcl/src/org/armedbear/lisp/apropos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/apropos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/apropos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/apropos.lisp Fri Oct 1 17:40:50 2010 @@ -49,11 +49,12 @@ (push symbol result))) result) (mapcan (lambda (package) - (apropos-list string-designator package)) - (list-all-packages)))) + (apropos-list string-designator package)) + (list-all-packages)))) (defun apropos (string-designator &optional package-designator) - (dolist (symbol (apropos-list string-designator package-designator)) + (dolist (symbol (remove-duplicates (apropos-list string-designator + package-designator))) (fresh-line) (prin1 symbol) (when (boundp symbol) From ehuelsmann at common-lisp.net Sat Oct 2 07:36:11 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 02 Oct 2010 03:36:11 -0400 Subject: [armedbear-cvs] r12935 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: ehuelsmann Date: Sat Oct 2 03:36:08 2010 New Revision: 12935 Log: Fix #107: Incorrect compilation of (SETF STRUCTURE-REF) expansion. Modified: trunk/abcl/src/org/armedbear/lisp/setf.lisp trunk/abcl/test/lisp/abcl/misc-tests.lisp Modified: trunk/abcl/src/org/armedbear/lisp/setf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/setf.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/setf.lisp Sat Oct 2 03:36:08 2010 @@ -240,4 +240,6 @@ (defsetf function-info %set-function-info) -(defsetf stream-external-format %set-stream-external-format) \ No newline at end of file +(defsetf stream-external-format %set-stream-external-format) + +(defsetf structure-ref structure-set) Modified: trunk/abcl/test/lisp/abcl/misc-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/misc-tests.lisp (original) +++ trunk/abcl/test/lisp/abcl/misc-tests.lisp Sat Oct 2 03:36:08 2010 @@ -96,3 +96,16 @@ (read-from-string "(1 2 #+nil #k(3 4))") (1 2) 19) + +;; executed of the compiled expression below +;; resulted in an error on pre-0.23 versions +(defstruct mystruct slot) +(deftest ticket.107 + (funcall (compile nil + '(lambda () + (let ((struct (make-mystruct)) + x) + (setf (values (mystruct-slot struct) + x) + (values 42 2)))))) + 42 2) \ No newline at end of file From ehuelsmann at common-lisp.net Sat Oct 2 10:07:45 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 02 Oct 2010 06:07:45 -0400 Subject: [armedbear-cvs] r12936 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 2 06:07:43 2010 New Revision: 12936 Log: Fix build. Added: trunk/abcl/src/org/armedbear/lisp/CompiledPrimitive.java Added: trunk/abcl/src/org/armedbear/lisp/CompiledPrimitive.java ============================================================================== --- (empty file) +++ trunk/abcl/src/org/armedbear/lisp/CompiledPrimitive.java Sat Oct 2 06:07:43 2010 @@ -0,0 +1,94 @@ +/* + * CompiledPrimitive.java + * + * Copyright (C) 2002-2005 Peter Graves + * $Id: CompiledPrimitive.java 12826 2010-07-25 19:09:13Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class CompiledPrimitive extends Primitive +{ + public CompiledPrimitive(LispObject name) + { + super(name); + } + + public CompiledPrimitive(String name) + { + super(name); + } + + public CompiledPrimitive(Symbol symbol) + { + super(symbol); + } + + public CompiledPrimitive(Symbol symbol, String arglist) + { + super(symbol, arglist); + } + + public CompiledPrimitive(Symbol symbol, String arglist, String docstring) + { + super(symbol, arglist, docstring); + } + + public CompiledPrimitive(String name, String arglist) + { + super(name, arglist); + } + + public CompiledPrimitive(LispObject name, LispObject lambdaList) + { + super(name, lambdaList); + } + + public CompiledPrimitive(String name, Package pkg) + { + super(name, pkg); + } + + public CompiledPrimitive(String name, Package pkg, boolean exported) + { + super(name, pkg, exported); + } + + public CompiledPrimitive(String name, Package pkg, boolean exported, + String arglist) + { + super(name, pkg, exported, arglist); + } + + public CompiledPrimitive(String name, Package pkg, boolean exported, + String arglist, String docstring) + { + super(name, pkg, exported, arglist, docstring); + } +} From ehuelsmann at common-lisp.net Sat Oct 2 13:23:35 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 02 Oct 2010 09:23:35 -0400 Subject: [armedbear-cvs] r12937 - trunk/abcl Message-ID: Author: ehuelsmann Date: Sat Oct 2 09:23:33 2010 New Revision: 12937 Log: Update CHANGES with trunk progress. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Sat Oct 2 09:23:33 2010 @@ -15,6 +15,20 @@ * [svn r12927] Fix for regression to moved threads related symbols +* [ticket #104] SET changes value of symbols defined with DEFCONSTANT + +* [ticket #88] Need a predicate to indicate source of compiled version + ie Java vs Lisp + +* [ticket #106] DEFSTRUCT :include with :conc-name creating overwriting + inherited slot accessors + +* [ticket #97] Symbol imported in multiple packages reported multiple + times by APROPOS + +* [ticket #107] Incorrect compilation of (SETF STRUCTURE-REF) expansion + + Version 0.22 ============ svn://common-lisp.net/project/armedbear/svn/tags/0.22.0/abcl From ehuelsmann at common-lisp.net Sat Oct 2 19:00:56 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 02 Oct 2010 15:00:56 -0400 Subject: [armedbear-cvs] r12938 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 2 15:00:52 2010 New Revision: 12938 Log: Fix partial date format support while parsing Last-Modified in ZipCache. While at it, fix a locale issue too; the dates sent are required to be US locale, not NL or any other. Note: My system tried to parse the dates with an NL locale, failing to understand the names of the days and months. Modified: trunk/abcl/src/org/armedbear/lisp/ZipCache.java Modified: trunk/abcl/src/org/armedbear/lisp/ZipCache.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ZipCache.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ZipCache.java Sat Oct 2 15:00:52 2010 @@ -41,10 +41,11 @@ import java.net.MalformedURLException; import java.net.URL; import java.net.URLConnection; -import java.text.ParseException; +import java.text.ParsePosition; import java.text.SimpleDateFormat; import java.util.Date; import java.util.HashMap; +import java.util.Locale; import java.util.zip.ZipException; import java.util.zip.ZipFile; @@ -101,8 +102,13 @@ return get(Pathname.makeURL(p)); } + static final SimpleDateFormat ASCTIME + = new SimpleDateFormat("EEE MMM d HH:mm:ss yyyy", Locale.US); + static final SimpleDateFormat RFC_1036 + = new SimpleDateFormat("EEEE, dd-MMM-yy HH:mm:ss zzz", Locale.US); static final SimpleDateFormat RFC_1123 - = new SimpleDateFormat("EEE, dd MMM yyyy HH:mm:ss zzz"); + = new SimpleDateFormat("EEE, dd MMM yyyy HH:mm:ss zzz", Locale.US); + synchronized public static ZipFile get(final URL url) { if (!cacheEnabled) { @@ -160,22 +166,31 @@ // refetch the resource.n String dateString = HttpHead.get(url, "Last-Modified"); Date date = null; - try { - if (dateString == null) { - throw new ParseException("Failed to get HEAD for " + url, 0); - } - date = RFC_1123.parse(dateString); - long current = date.getTime(); - if (current > entry.lastModified) { - entry = fetchURL(url, false); - zipCache.put(url, entry); + ParsePosition pos = new ParsePosition(0); + + if (dateString != null) { + date = RFC_1123.parse(dateString, pos); + if (date == null) { + date = RFC_1036.parse(dateString, pos); + if (date == null) + date = ASCTIME.parse(dateString, pos); } - } catch (ParseException e) { - Debug.trace("Failed to parse HTTP Last-Modified field: " + e); - entry = fetchURL(url, false); - zipCache.put(url, entry); } - } else { + + if (date == null || date.getTime() > entry.lastModified) { + entry = fetchURL(url, false); + zipCache.put(url, entry); + } + if (date == null) { + if (dateString == null) + Debug.trace("Failed to retrieve request header: " + + url.toString()); + else + Debug.trace("Failed to parse Last-Modified date: " + + dateString); + } + + } else { entry = fetchURL(url, false); zipCache.put(url, entry); } From ehuelsmann at common-lisp.net Sat Oct 2 19:04:02 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 02 Oct 2010 15:04:02 -0400 Subject: [armedbear-cvs] r12939 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 2 15:04:00 2010 New Revision: 12939 Log: Fix COERCE on a COMPLEX, being coerced to (COMPLEX ); this is excercised by Maxima. Modified: trunk/abcl/src/org/armedbear/lisp/coerce.lisp Modified: trunk/abcl/src/org/armedbear/lisp/coerce.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/coerce.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/coerce.lisp Sat Oct 2 15:04:00 2010 @@ -105,9 +105,14 @@ (coerce-to-function object)) ((and (consp result-type) (eq (%car result-type) 'complex)) + (when (complexp object) + (return-from coerce + (complex (coerce (realpart object) (cadr result-type)) + (coerce (imagpart object) (cadr result-type))))) (if (memq (%cadr result-type) '(float single-float double-float short-float long-float)) - (complex object 0.0) + (complex (coerce object (cadr result-type)) + (coerce 0.0 (cadr result-type))) object)) ((and (consp result-type) (eq (%car result-type) 'AND)) From ehuelsmann at common-lisp.net Sat Oct 2 21:39:53 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 02 Oct 2010 17:39:53 -0400 Subject: [armedbear-cvs] r12940 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 2 17:39:52 2010 New Revision: 12940 Log: Fix loss of precision in (expt ), fixes last Maxima failure. Modified: trunk/abcl/src/org/armedbear/lisp/Complex.java trunk/abcl/src/org/armedbear/lisp/MathFunctions.java Modified: trunk/abcl/src/org/armedbear/lisp/Complex.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Complex.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Complex.java Sat Oct 2 17:39:52 2010 @@ -80,6 +80,15 @@ return imagpart; } + /** Coerces the complex parts into DoubleFloats + * + * @return a new complex with double-float real and imaginary parts + */ + public LispObject coerceToDoubleFloat() { + return getInstance(DoubleFloat.coerceToFloat(realpart), + DoubleFloat.coerceToFloat(imagpart)); + } + @Override public LispObject typeOf() { Modified: trunk/abcl/src/org/armedbear/lisp/MathFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/MathFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/MathFunctions.java Sat Oct 2 17:39:52 2010 @@ -623,6 +623,34 @@ } // for anything not a rational or complex rational, use // float approximation. + boolean wantDoubleFloat = false; + if (base instanceof DoubleFloat) + wantDoubleFloat = true; + else if (power instanceof DoubleFloat) + wantDoubleFloat = true; + else if (base instanceof Complex + && (((Complex)base).getRealPart() instanceof DoubleFloat + || ((Complex)base).getImaginaryPart() instanceof DoubleFloat)) + wantDoubleFloat = true; + else if (power instanceof Complex + && (((Complex)power).getRealPart() instanceof DoubleFloat + || ((Complex)power).getImaginaryPart() instanceof DoubleFloat)) + wantDoubleFloat = true; + + if (wantDoubleFloat) { + if (power instanceof Complex) + power = ((Complex)power).coerceToDoubleFloat(); + else + power = DoubleFloat.coerceToFloat(power); + + if (base instanceof Complex) + base = ((Complex)base).coerceToDoubleFloat(); + else + base = DoubleFloat.coerceToFloat(base); + } + + + if (base instanceof Complex || power instanceof Complex) return exp(power.multiplyBy(log(base))); final double x; // base From ehuelsmann at common-lisp.net Sun Oct 3 08:47:53 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 03 Oct 2010 04:47:53 -0400 Subject: [armedbear-cvs] r12941 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Oct 3 04:47:49 2010 New Revision: 12941 Log: Add ANALYZE-LOCALS, which should have been on the generic-class-file branch before merge-back. Modified: trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Modified: trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Sun Oct 3 04:47:49 2010 @@ -1,6 +1,7 @@ ;;; jvm-instructions.lisp ;;; ;;; Copyright (C) 2003-2006 Peter Graves +;;; Copyright (C) 2010 Erik Huelsmann ;;; $Id$ ;;; ;;; This program is free software; you can redistribute it and/or @@ -38,229 +39,230 @@ (defconst *opcodes* (make-hash-table :test 'equalp)) -(defstruct jvm-opcode name number size stack-effect) +(defstruct jvm-opcode name number size stack-effect register-used) -(defun %define-opcode (name number size stack-effect) +(defun %define-opcode (name number size stack-effect register) (declare (type fixnum number size)) (let* ((name (string name)) (opcode (make-jvm-opcode :name name :number number :size size - :stack-effect stack-effect))) + :stack-effect stack-effect + :register-used register))) (setf (svref *opcode-table* number) opcode) (setf (gethash name *opcodes*) opcode) (setf (gethash number *opcodes*) opcode))) -(defmacro define-opcode (name number size stack-effect) - `(%define-opcode ',name ,number ,size ,stack-effect)) +(defmacro define-opcode (name number size stack-effect register) + `(%define-opcode ',name ,number ,size ,stack-effect ,register)) -;; name number size stack-effect (nil if unknown) -(define-opcode nop 0 1 0) -(define-opcode aconst_null 1 1 1) -(define-opcode iconst_m1 2 1 1) -(define-opcode iconst_0 3 1 1) -(define-opcode iconst_1 4 1 1) -(define-opcode iconst_2 5 1 1) -(define-opcode iconst_3 6 1 1) -(define-opcode iconst_4 7 1 1) -(define-opcode iconst_5 8 1 1) -(define-opcode lconst_0 9 1 2) -(define-opcode lconst_1 10 1 2) -(define-opcode fconst_0 11 1 1) -(define-opcode fconst_1 12 1 1) -(define-opcode fconst_2 13 1 1) -(define-opcode dconst_0 14 1 2) -(define-opcode dconst_1 15 1 2) -(define-opcode bipush 16 2 1) -(define-opcode sipush 17 3 1) -(define-opcode ldc 18 2 1) -(define-opcode ldc_w 19 3 1) -(define-opcode ldc2_w 20 3 2) -(define-opcode iload 21 2 1) -(define-opcode lload 22 2 2) -(define-opcode fload 23 2 nil) -(define-opcode dload 24 2 nil) -(define-opcode aload 25 2 1) -(define-opcode iload_0 26 1 1) -(define-opcode iload_1 27 1 1) -(define-opcode iload_2 28 1 1) -(define-opcode iload_3 29 1 1) -(define-opcode lload_0 30 1 2) -(define-opcode lload_1 31 1 2) -(define-opcode lload_2 32 1 2) -(define-opcode lload_3 33 1 2) -(define-opcode fload_0 34 1 nil) -(define-opcode fload_1 35 1 nil) -(define-opcode fload_2 36 1 nil) -(define-opcode fload_3 37 1 nil) -(define-opcode dload_0 38 1 nil) -(define-opcode dload_1 39 1 nil) -(define-opcode dload_2 40 1 nil) -(define-opcode dload_3 41 1 nil) -(define-opcode aload_0 42 1 1) -(define-opcode aload_1 43 1 1) -(define-opcode aload_2 44 1 1) -(define-opcode aload_3 45 1 1) -(define-opcode iaload 46 1 -1) -(define-opcode laload 47 1 0) -(define-opcode faload 48 1 -1) -(define-opcode daload 49 1 0) -(define-opcode aaload 50 1 -1) -(define-opcode baload 51 1 nil) -(define-opcode caload 52 1 nil) -(define-opcode saload 53 1 nil) -(define-opcode istore 54 2 -1) -(define-opcode lstore 55 2 -2) -(define-opcode fstore 56 2 nil) -(define-opcode dstore 57 2 nil) -(define-opcode astore 58 2 -1) -(define-opcode istore_0 59 1 -1) -(define-opcode istore_1 60 1 -1) -(define-opcode istore_2 61 1 -1) -(define-opcode istore_3 62 1 -1) -(define-opcode lstore_0 63 1 -2) -(define-opcode lstore_1 64 1 -2) -(define-opcode lstore_2 65 1 -2) -(define-opcode lstore_3 66 1 -2) -(define-opcode fstore_0 67 1 nil) -(define-opcode fstore_1 68 1 nil) -(define-opcode fstore_2 69 1 nil) -(define-opcode fstore_3 70 1 nil) -(define-opcode dstore_0 71 1 nil) -(define-opcode dstore_1 72 1 nil) -(define-opcode dstore_2 73 1 nil) -(define-opcode dstore_3 74 1 nil) -(define-opcode astore_0 75 1 -1) -(define-opcode astore_1 76 1 -1) -(define-opcode astore_2 77 1 -1) -(define-opcode astore_3 78 1 -1) -(define-opcode iastore 79 1 -3) -(define-opcode lastore 80 1 -4) -(define-opcode fastore 81 1 -3) -(define-opcode dastore 82 1 -4) -(define-opcode aastore 83 1 -3) -(define-opcode bastore 84 1 nil) -(define-opcode castore 85 1 nil) -(define-opcode sastore 86 1 nil) -(define-opcode pop 87 1 -1) -(define-opcode pop2 88 1 -2) -(define-opcode dup 89 1 1) -(define-opcode dup_x1 90 1 1) -(define-opcode dup_x2 91 1 1) -(define-opcode dup2 92 1 2) -(define-opcode dup2_x1 93 1 2) -(define-opcode dup2_x2 94 1 2) -(define-opcode swap 95 1 0) -(define-opcode iadd 96 1 -1) -(define-opcode ladd 97 1 -2) -(define-opcode fadd 98 1 -1) -(define-opcode dadd 99 1 -2) -(define-opcode isub 100 1 -1) -(define-opcode lsub 101 1 -2) -(define-opcode fsub 102 1 -1) -(define-opcode dsub 103 1 -2) -(define-opcode imul 104 1 -1) -(define-opcode lmul 105 1 -2) -(define-opcode fmul 106 1 -1) -(define-opcode dmul 107 1 -2) -(define-opcode idiv 108 1 nil) -(define-opcode ldiv 109 1 nil) -(define-opcode fdiv 110 1 nil) -(define-opcode ddiv 111 1 nil) -(define-opcode irem 112 1 nil) -(define-opcode lrem 113 1 nil) -(define-opcode frem 114 1 nil) -(define-opcode drem 115 1 nil) -(define-opcode ineg 116 1 0) -(define-opcode lneg 117 1 0) -(define-opcode fneg 118 1 0) -(define-opcode dneg 119 1 0) -(define-opcode ishl 120 1 -1) -(define-opcode lshl 121 1 -1) -(define-opcode ishr 122 1 -1) -(define-opcode lshr 123 1 -1) -(define-opcode iushr 124 1 nil) -(define-opcode lushr 125 1 nil) -(define-opcode iand 126 1 -1) -(define-opcode land 127 1 -2) -(define-opcode ior 128 1 -1) -(define-opcode lor 129 1 -2) -(define-opcode ixor 130 1 -1) -(define-opcode lxor 131 1 -2) -(define-opcode iinc 132 3 0) -(define-opcode i2l 133 1 1) -(define-opcode i2f 134 1 0) -(define-opcode i2d 135 1 1) -(define-opcode l2i 136 1 -1) -(define-opcode l2f 137 1 -1) -(define-opcode l2d 138 1 0) -(define-opcode f2i 139 1 nil) -(define-opcode f2l 140 1 nil) -(define-opcode f2d 141 1 1) -(define-opcode d2i 142 1 nil) -(define-opcode d2l 143 1 nil) -(define-opcode d2f 144 1 -1) -(define-opcode i2b 145 1 nil) -(define-opcode i2c 146 1 nil) -(define-opcode i2s 147 1 nil) -(define-opcode lcmp 148 1 -3) -(define-opcode fcmpl 149 1 -1) -(define-opcode fcmpg 150 1 -1) -(define-opcode dcmpl 151 1 -3) -(define-opcode dcmpg 152 1 -3) -(define-opcode ifeq 153 3 -1) -(define-opcode ifne 154 3 -1) -(define-opcode iflt 155 3 -1) -(define-opcode ifge 156 3 -1) -(define-opcode ifgt 157 3 -1) -(define-opcode ifle 158 3 -1) -(define-opcode if_icmpeq 159 3 -2) -(define-opcode if_icmpne 160 3 -2) -(define-opcode if_icmplt 161 3 -2) -(define-opcode if_icmpge 162 3 -2) -(define-opcode if_icmpgt 163 3 -2) -(define-opcode if_icmple 164 3 -2) -(define-opcode if_acmpeq 165 3 -2) -(define-opcode if_acmpne 166 3 -2) -(define-opcode goto 167 3 0) +;; name number size stack-effect register-used +(define-opcode nop 0 1 0 nil) +(define-opcode aconst_null 1 1 1 nil) +(define-opcode iconst_m1 2 1 1 nil) +(define-opcode iconst_0 3 1 1 nil) +(define-opcode iconst_1 4 1 1 nil) +(define-opcode iconst_2 5 1 1 nil) +(define-opcode iconst_3 6 1 1 nil) +(define-opcode iconst_4 7 1 1 nil) +(define-opcode iconst_5 8 1 1 nil) +(define-opcode lconst_0 9 1 2 nil) +(define-opcode lconst_1 10 1 2 nil) +(define-opcode fconst_0 11 1 1 nil) +(define-opcode fconst_1 12 1 1 nil) +(define-opcode fconst_2 13 1 1 nil) +(define-opcode dconst_0 14 1 2 nil) +(define-opcode dconst_1 15 1 2 nil) +(define-opcode bipush 16 2 1 nil) +(define-opcode sipush 17 3 1 nil) +(define-opcode ldc 18 2 1 nil) +(define-opcode ldc_w 19 3 1 nil) +(define-opcode ldc2_w 20 3 2 nil) +(define-opcode iload 21 2 1 t) +(define-opcode lload 22 2 2 t) +(define-opcode fload 23 2 nil t) +(define-opcode dload 24 2 nil t) +(define-opcode aload 25 2 1 t) +(define-opcode iload_0 26 1 1 0) +(define-opcode iload_1 27 1 1 1) +(define-opcode iload_2 28 1 1 2) +(define-opcode iload_3 29 1 1 3) +(define-opcode lload_0 30 1 2 0) +(define-opcode lload_1 31 1 2 1) +(define-opcode lload_2 32 1 2 2) +(define-opcode lload_3 33 1 2 3) +(define-opcode fload_0 34 1 nil 0) +(define-opcode fload_1 35 1 nil 1) +(define-opcode fload_2 36 1 nil 2) +(define-opcode fload_3 37 1 nil 3) +(define-opcode dload_0 38 1 nil 0) +(define-opcode dload_1 39 1 nil 1) +(define-opcode dload_2 40 1 nil 2) +(define-opcode dload_3 41 1 nil 3) +(define-opcode aload_0 42 1 1 0) +(define-opcode aload_1 43 1 1 1) +(define-opcode aload_2 44 1 1 2) +(define-opcode aload_3 45 1 1 3) +(define-opcode iaload 46 1 -1 nil) +(define-opcode laload 47 1 0 nil) +(define-opcode faload 48 1 -1 nil) +(define-opcode daload 49 1 0 nil) +(define-opcode aaload 50 1 -1 nil) +(define-opcode baload 51 1 nil nil) +(define-opcode caload 52 1 nil nil) +(define-opcode saload 53 1 nil nil) +(define-opcode istore 54 2 -1 t) +(define-opcode lstore 55 2 -2 t) +(define-opcode fstore 56 2 nil t) +(define-opcode dstore 57 2 nil t) +(define-opcode astore 58 2 -1 t) +(define-opcode istore_0 59 1 -1 0) +(define-opcode istore_1 60 1 -1 1) +(define-opcode istore_2 61 1 -1 2) +(define-opcode istore_3 62 1 -1 3) +(define-opcode lstore_0 63 1 -2 0) +(define-opcode lstore_1 64 1 -2 1) +(define-opcode lstore_2 65 1 -2 2) +(define-opcode lstore_3 66 1 -2 3) +(define-opcode fstore_0 67 1 nil 0) +(define-opcode fstore_1 68 1 nil 1) +(define-opcode fstore_2 69 1 nil 2) +(define-opcode fstore_3 70 1 nil 3) +(define-opcode dstore_0 71 1 nil 0) +(define-opcode dstore_1 72 1 nil 1) +(define-opcode dstore_2 73 1 nil 2) +(define-opcode dstore_3 74 1 nil 3) +(define-opcode astore_0 75 1 -1 0) +(define-opcode astore_1 76 1 -1 1) +(define-opcode astore_2 77 1 -1 2) +(define-opcode astore_3 78 1 -1 3) +(define-opcode iastore 79 1 -3 nil) +(define-opcode lastore 80 1 -4 nil) +(define-opcode fastore 81 1 -3 nil) +(define-opcode dastore 82 1 -4 nil) +(define-opcode aastore 83 1 -3 nil) +(define-opcode bastore 84 1 nil nil) +(define-opcode castore 85 1 nil nil) +(define-opcode sastore 86 1 nil nil) +(define-opcode pop 87 1 -1 nil) +(define-opcode pop2 88 1 -2 nil) +(define-opcode dup 89 1 1 nil) +(define-opcode dup_x1 90 1 1 nil) +(define-opcode dup_x2 91 1 1 nil) +(define-opcode dup2 92 1 2 nil) +(define-opcode dup2_x1 93 1 2 nil) +(define-opcode dup2_x2 94 1 2 nil) +(define-opcode swap 95 1 0 nil) +(define-opcode iadd 96 1 -1 nil) +(define-opcode ladd 97 1 -2 nil) +(define-opcode fadd 98 1 -1 nil) +(define-opcode dadd 99 1 -2 nil) +(define-opcode isub 100 1 -1 nil) +(define-opcode lsub 101 1 -2 nil) +(define-opcode fsub 102 1 -1 nil) +(define-opcode dsub 103 1 -2 nil) +(define-opcode imul 104 1 -1 nil) +(define-opcode lmul 105 1 -2 nil) +(define-opcode fmul 106 1 -1 nil) +(define-opcode dmul 107 1 -2 nil) +(define-opcode idiv 108 1 nil nil) +(define-opcode ldiv 109 1 nil nil) +(define-opcode fdiv 110 1 nil nil) +(define-opcode ddiv 111 1 nil nil) +(define-opcode irem 112 1 nil nil) +(define-opcode lrem 113 1 nil nil) +(define-opcode frem 114 1 nil nil) +(define-opcode drem 115 1 nil nil) +(define-opcode ineg 116 1 0 nil) +(define-opcode lneg 117 1 0 nil) +(define-opcode fneg 118 1 0 nil) +(define-opcode dneg 119 1 0 nil) +(define-opcode ishl 120 1 -1 nil) +(define-opcode lshl 121 1 -1 nil) +(define-opcode ishr 122 1 -1 nil) +(define-opcode lshr 123 1 -1 nil) +(define-opcode iushr 124 1 nil nil) +(define-opcode lushr 125 1 nil nil) +(define-opcode iand 126 1 -1 nil) +(define-opcode land 127 1 -2 nil) +(define-opcode ior 128 1 -1 nil) +(define-opcode lor 129 1 -2 nil) +(define-opcode ixor 130 1 -1 nil) +(define-opcode lxor 131 1 -2 nil) +(define-opcode iinc 132 3 0 t) +(define-opcode i2l 133 1 1 nil) +(define-opcode i2f 134 1 0 nil) +(define-opcode i2d 135 1 1 nil) +(define-opcode l2i 136 1 -1 nil) +(define-opcode l2f 137 1 -1 nil) +(define-opcode l2d 138 1 0 nil) +(define-opcode f2i 139 1 nil nil) +(define-opcode f2l 140 1 nil nil) +(define-opcode f2d 141 1 1 nil) +(define-opcode d2i 142 1 nil nil) +(define-opcode d2l 143 1 nil nil) +(define-opcode d2f 144 1 -1 nil) +(define-opcode i2b 145 1 nil nil) +(define-opcode i2c 146 1 nil nil) +(define-opcode i2s 147 1 nil nil) +(define-opcode lcmp 148 1 -3 nil) +(define-opcode fcmpl 149 1 -1 nil) +(define-opcode fcmpg 150 1 -1 nil) +(define-opcode dcmpl 151 1 -3 nil) +(define-opcode dcmpg 152 1 -3 nil) +(define-opcode ifeq 153 3 -1 nil) +(define-opcode ifne 154 3 -1 nil) +(define-opcode iflt 155 3 -1 nil) +(define-opcode ifge 156 3 -1 nil) +(define-opcode ifgt 157 3 -1 nil) +(define-opcode ifle 158 3 -1 nil) +(define-opcode if_icmpeq 159 3 -2 nil) +(define-opcode if_icmpne 160 3 -2 nil) +(define-opcode if_icmplt 161 3 -2 nil) +(define-opcode if_icmpge 162 3 -2 nil) +(define-opcode if_icmpgt 163 3 -2 nil) +(define-opcode if_icmple 164 3 -2 nil) +(define-opcode if_acmpeq 165 3 -2 nil) +(define-opcode if_acmpne 166 3 -2 nil) +(define-opcode goto 167 3 0 nil) ;;(define-opcode jsr 168 3 1) Don't use these 2 opcodes: deprecated ;;(define-opcode ret 169 2 0) their use results in JVM verifier errors -(define-opcode tableswitch 170 0 nil) -(define-opcode lookupswitch 171 0 nil) -(define-opcode ireturn 172 1 nil) -(define-opcode lreturn 173 1 nil) -(define-opcode freturn 174 1 nil) -(define-opcode dreturn 175 1 nil) -(define-opcode areturn 176 1 -1) -(define-opcode return 177 1 0) -(define-opcode getstatic 178 3 1) -(define-opcode putstatic 179 3 -1) -(define-opcode getfield 180 3 0) -(define-opcode putfield 181 3 -2) -(define-opcode invokevirtual 182 3 nil) -(define-opcode invokespecial 183 3 nil) -(define-opcode invokestatic 184 3 nil) -(define-opcode invokeinterface 185 5 nil) -(define-opcode unused 186 0 nil) -(define-opcode new 187 3 1) -(define-opcode newarray 188 2 nil) -(define-opcode anewarray 189 3 0) -(define-opcode arraylength 190 1 0) -(define-opcode athrow 191 1 0) -(define-opcode checkcast 192 3 0) -(define-opcode instanceof 193 3 0) -(define-opcode monitorenter 194 1 -1) -(define-opcode monitorexit 195 1 -1) -(define-opcode wide 196 0 nil) -(define-opcode multianewarray 197 4 nil) -(define-opcode ifnull 198 3 -1) -(define-opcode ifnonnull 199 3 nil) -(define-opcode goto_w 200 5 nil) +(define-opcode tableswitch 170 0 nil nil) +(define-opcode lookupswitch 171 0 nil nil) +(define-opcode ireturn 172 1 nil nil) +(define-opcode lreturn 173 1 nil nil) +(define-opcode freturn 174 1 nil nil) +(define-opcode dreturn 175 1 nil nil) +(define-opcode areturn 176 1 -1 nil) +(define-opcode return 177 1 0 nil) +(define-opcode getstatic 178 3 1 nil) +(define-opcode putstatic 179 3 -1 nil) +(define-opcode getfield 180 3 0 nil) +(define-opcode putfield 181 3 -2 nil) +(define-opcode invokevirtual 182 3 nil nil) +(define-opcode invokespecial 183 3 nil nil) +(define-opcode invokestatic 184 3 nil nil) +(define-opcode invokeinterface 185 5 nil nil) +(define-opcode unused 186 0 nil nil) +(define-opcode new 187 3 1 nil) +(define-opcode newarray 188 2 nil nil) +(define-opcode anewarray 189 3 0 nil) +(define-opcode arraylength 190 1 0 nil) +(define-opcode athrow 191 1 0 nil) +(define-opcode checkcast 192 3 0 nil) +(define-opcode instanceof 193 3 0 nil) +(define-opcode monitorenter 194 1 -1 nil) +(define-opcode monitorexit 195 1 -1 nil) +(define-opcode wide 196 0 nil nil) +(define-opcode multianewarray 197 4 nil nil) +(define-opcode ifnull 198 3 -1 nil) +(define-opcode ifnonnull 199 3 nil nil) +(define-opcode goto_w 200 5 nil nil) ;; (define-opcode jsr_w 201 5 nil) Don't use: deprecated -(define-opcode label 202 0 0) ;; virtual: does not exist in the JVM +(define-opcode label 202 0 0 nil) ;; virtual: does not exist in the JVM ;; (define-opcode push-value 203 nil 1) ;; (define-opcode store-value 204 nil -1) -(define-opcode clear-values 205 0 0) ;; virtual: does not exist in the JVM +(define-opcode clear-values 205 0 0 t) ;; virtual: does not exist in the JVM ;;(define-opcode var-ref 206 0 0) (defparameter *last-opcode* 206) @@ -767,6 +769,20 @@ (setf max-stack (max max-stack (the fixnum instruction-depth)))))) max-stack))) +(defun analyze-locals (code) + (let ((code-length (length code)) + (max-local 0)) + (dotimes (i code-length max-local) + (let* ((instruction (aref code i)) + (opcode (instruction-opcode instruction))) + (setf max-local + (max max-local + (or (let ((opcode-register + (jvm-opcode-register-used opcode))) + (if (eq t opcode-register) + (car (instruction-args instruction)) + opcode-register)) + 0))))))) (defun delete-unused-labels (code handler-labels) (declare (optimize speed)) From ehuelsmann at common-lisp.net Sun Oct 3 09:08:58 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 03 Oct 2010 05:08:58 -0400 Subject: [armedbear-cvs] r12942 - trunk/abcl/test/lisp/abcl Message-ID: Author: ehuelsmann Date: Sun Oct 3 05:08:55 2010 New Revision: 12942 Log: Fix !-prefixed symbols: there are no duplicate symbols anymore; replacement work has been done: everything is on trunk. Modified: trunk/abcl/test/lisp/abcl/class-file.lisp Modified: trunk/abcl/test/lisp/abcl/class-file.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/class-file.lisp (original) +++ trunk/abcl/test/lisp/abcl/class-file.lisp Sun Oct 3 05:08:55 2010 @@ -160,24 +160,24 @@ (deftest make-class-file.1 (let* ((class (jvm::make-class-name "org/armedbear/lisp/mcf_1")) - (file (jvm::!make-class-file class jvm::+lisp-object+ '(:public)))) + (file (jvm::make-class-file class jvm::+lisp-object+ '(:public)))) (jvm::class-add-field file (jvm::make-field "ABC" :int)) (jvm::class-add-field file (jvm::make-field "ABD" jvm::+lisp-object+)) - (jvm::class-add-method file (jvm::!make-method "MBC" nil :int)) - (jvm::class-add-method file (jvm::!make-method "MBD" nil jvm::+lisp-object+)) - (jvm::class-add-method file (jvm::!make-method :constructor :void nil)) - (jvm::class-add-method file (jvm::!make-method :class-constructor :void nil)) + (jvm::class-add-method file (jvm::make-method "MBC" nil :int)) + (jvm::class-add-method file (jvm::make-method "MBD" nil jvm::+lisp-object+)) + (jvm::class-add-method file (jvm::make-method :constructor :void nil)) + (jvm::class-add-method file (jvm::make-method :class-constructor :void nil)) T) T) (deftest finalize-class-file.1 (let* ((class (jvm::make-class-name "org/armedbear/lisp/fcf_1")) - (file (jvm::!make-class-file class jvm::+lisp-object+ '(:public)))) + (file (jvm::make-class-file class jvm::+lisp-object+ '(:public)))) (jvm::class-add-field file (jvm::make-field "ABC" :int)) (jvm::class-add-field file (jvm::make-field "ABD" jvm::+lisp-object+)) - (jvm::class-add-method file (jvm::!make-method "MBC" nil '(:int))) + (jvm::class-add-method file (jvm::make-method "MBC" nil '(:int))) (jvm::class-add-method file - (jvm::!make-method "MBD" nil + (jvm::make-method "MBD" nil (list jvm::+lisp-object+))) (jvm::finalize-class-file file) file @@ -186,23 +186,23 @@ (deftest generate-method.1 (let* ((class (jvm::make-class-name "org/armedbear/lisp/gm_1")) - (file (jvm::!make-class-file class jvm::+lisp-object+ '(:public))) - (method (jvm::!make-method :class-constructor :void nil + (file (jvm::make-class-file class jvm::+lisp-object+ '(:public))) + (method (jvm::make-method :class-constructor :void nil :flags '(:static)))) (jvm::class-add-method file method) (jvm::with-code-to-method (file method) (jvm::emit 'return)) (jvm::finalize-class-file file) (with-open-stream (stream (sys::%make-byte-array-output-stream)) - (jvm::!write-class-file file stream) + (jvm::write-class-file file stream) (sys::load-compiled-function (sys::%get-output-stream-bytes stream))) T) T) (deftest generate-method.2 (let* ((class (jvm::make-class-name "org/armedbear/lisp/gm_2")) - (file (jvm::!make-class-file class jvm::+lisp-object+ '(:public))) - (method (jvm::!make-method "doNothing" :void nil))) + (file (jvm::make-class-file class jvm::+lisp-object+ '(:public))) + (method (jvm::make-method "doNothing" :void nil))) (jvm::class-add-method file method) (jvm::with-code-to-method (file method) (let ((label1 (gensym)) @@ -218,7 +218,7 @@ (jvm::emit 'return)) (jvm::finalize-class-file file) (with-open-stream (stream (sys::%make-byte-array-output-stream)) - (jvm::!write-class-file file stream) + (jvm::write-class-file file stream) (sys::load-compiled-function (sys::%get-output-stream-bytes stream))) T) T) @@ -226,9 +226,9 @@ ;; generation of an ABCL-like function class (deftest generate-method.3 (let* ((class (jvm::make-class-name "org.armedbear.lisp.gm_3")) - (file (jvm::!make-class-file class jvm::+lisp-primitive+ '(:public))) + (file (jvm::make-class-file class jvm::+lisp-primitive+ '(:public))) ) - (let ((method (jvm::!make-method :constructor :void nil))) + (let ((method (jvm::make-method :constructor :void nil))) (jvm::class-add-method file method) (jvm::with-code-to-method (file method) (jvm::emit 'aload 0) @@ -238,14 +238,14 @@ (list jvm::+lisp-object+ jvm::+lisp-object+)) (jvm::emit 'return))) - (let ((method (jvm::!make-method "execute" jvm::+lisp-object+ nil))) + (let ((method (jvm::make-method "execute" jvm::+lisp-object+ nil))) (jvm::class-add-method file method) (jvm::with-code-to-method (file method) (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+) (jvm::emit 'jvm::areturn))) (jvm::finalize-class-file file) (with-open-stream (stream (sys::%make-byte-array-output-stream)) - (jvm::!write-class-file file stream) + (jvm::write-class-file file stream) (funcall (sys::load-compiled-function (sys::%get-output-stream-bytes stream))))) NIL) @@ -253,17 +253,17 @@ ;; static field (deftest generate-method.4 (let* ((class (jvm::make-class-name "org.armedbear.lisp.gm_4")) - (file (jvm::!make-class-file class jvm::+lisp-primitive+ '(:public))) + (file (jvm::make-class-file class jvm::+lisp-primitive+ '(:public))) ) - (jvm::class-add-field file (jvm::!make-field "N1" jvm::+lisp-object+ + (jvm::class-add-field file (jvm::make-field "N1" jvm::+lisp-object+ :flags '(:static :private))) - (let ((method (jvm::!make-method :class-constructor :void nil :flags '(:static)))) + (let ((method (jvm::make-method :class-constructor :void nil :flags '(:static)))) (jvm::class-add-method file method) (jvm::with-code-to-method (file method) (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+) (jvm::emit-putstatic class "N1" jvm::+lisp-object+) (jvm::emit 'return))) - (let ((method (jvm::!make-method :constructor :void nil))) + (let ((method (jvm::make-method :constructor :void nil))) (jvm::class-add-method file method) (jvm::with-code-to-method (file method) (jvm::emit 'aload 0) @@ -273,14 +273,14 @@ (list jvm::+lisp-object+ jvm::+lisp-object+)) (jvm::emit 'return))) - (let ((method (jvm::!make-method "execute" jvm::+lisp-object+ nil))) + (let ((method (jvm::make-method "execute" jvm::+lisp-object+ nil))) (jvm::class-add-method file method) (jvm::with-code-to-method (file method) (jvm::emit-getstatic class "N1" jvm::+lisp-object+) (jvm::emit 'jvm::areturn))) (jvm::finalize-class-file file) (with-open-stream (stream (sys::%make-byte-array-output-stream)) - (jvm::!write-class-file file stream) + (jvm::write-class-file file stream) (funcall (sys::load-compiled-function (sys::%get-output-stream-bytes stream))))) NIL) @@ -288,9 +288,9 @@ ;; generation of ABCL-like function class with multiple 'execute' methods (deftest generate-method.5 (let* ((class (jvm::make-class-name "org.armedbear.lisp.gm_5")) - (file (jvm::!make-class-file class jvm::+lisp-primitive+ '(:public))) + (file (jvm::make-class-file class jvm::+lisp-primitive+ '(:public))) ) - (let ((method (jvm::!make-method :constructor :void nil))) + (let ((method (jvm::make-method :constructor :void nil))) (jvm::class-add-method file method) (jvm::with-code-to-method (file method) (jvm::emit 'aload 0) @@ -300,12 +300,12 @@ (list jvm::+lisp-object+ jvm::+lisp-object+)) (jvm::emit 'return))) - (let ((method (jvm::!make-method "execute" jvm::+lisp-object+ nil))) + (let ((method (jvm::make-method "execute" jvm::+lisp-object+ nil))) (jvm::class-add-method file method) (jvm::with-code-to-method (file method) (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+) (jvm::emit 'jvm::areturn))) - (let ((method (jvm::!make-method "execute" jvm::+lisp-object+ + (let ((method (jvm::make-method "execute" jvm::+lisp-object+ (list jvm::+lisp-object+)))) (jvm::class-add-method file method) (jvm::with-code-to-method (file method) @@ -313,7 +313,7 @@ (jvm::emit 'jvm::areturn))) (jvm::finalize-class-file file) (with-open-stream (stream (sys::%make-byte-array-output-stream)) - (jvm::!write-class-file file stream) + (jvm::write-class-file file stream) (let* ((bytes (sys::%get-output-stream-bytes stream)) (fn (sys::load-compiled-function bytes))) (values (funcall fn) (funcall fn NIL))))) @@ -322,8 +322,8 @@ ;;Nested with-code-to-method (deftest with-code-to-method.1 (let* ((class (jvm::make-class-name "org/armedbear/lisp/gm_6")) - (file (jvm::!make-class-file class jvm::+lisp-object+ '(:public))) - (method (jvm::!make-method :class-constructor :void nil + (file (jvm::make-class-file class jvm::+lisp-object+ '(:public))) + (method (jvm::make-method :class-constructor :void nil :flags '(:static))) (registers nil)) (jvm::class-add-method file method) @@ -346,10 +346,10 @@ (deftest with-code-to-method.2 (let* ((class (jvm::make-class-name "org/armedbear/lisp/gm_7")) - (file (jvm::!make-class-file class jvm::+lisp-object+ '(:public))) - (method1 (jvm::!make-method :class-constructor :void nil + (file (jvm::make-class-file class jvm::+lisp-object+ '(:public))) + (method1 (jvm::make-method :class-constructor :void nil :flags '(:static))) - (method2 (jvm::!make-method "method2" :void nil)) + (method2 (jvm::make-method "method2" :void nil)) (registers nil)) (jvm::class-add-method file method1) (jvm::class-add-method file method2) @@ -374,9 +374,9 @@ ;; ;; static initializer and function method(s) ;; (deftest generate-method.6 ;; (let* ((class (jvm::make-class-name "org.armedbear.lisp.gm_6")) -;; (file (jvm::!make-class-file class jvm::+lisp-primitive+ '(:public))) +;; (file (jvm::make-class-file class jvm::+lisp-primitive+ '(:public))) ;; ) -;; (let ((method (jvm::!make-method :constructor :void nil))) +;; (let ((method (jvm::make-method :constructor :void nil))) ;; (jvm::class-add-method file method) ;; (jvm::with-code-to-method (file method) ;; (jvm::emit 'aload 0) @@ -386,14 +386,14 @@ ;; (list jvm::+lisp-object+ ;; jvm::+lisp-object+)) ;; (jvm::emit 'return))) -;; (let ((method (jvm::!make-method "execute" jvm::+lisp-object+ nil))) +;; (let ((method (jvm::make-method "execute" jvm::+lisp-object+ nil))) ;; (jvm::class-add-method file method) ;; (jvm::with-code-to-method (file method) ;; (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+) ;; (jvm::emit 'jvm::areturn))) ;; (jvm::finalize-class-file file) ;; (with-open-stream (stream (sys::%make-byte-array-output-stream)) -;; (jvm::!write-class-file file stream) +;; (jvm::write-class-file file stream) ;; (ignore-errors (sys::load-compiled-function nil)) ;; (funcall (sys::load-compiled-function (sys::%get-output-stream-bytes stream)))) ;; T From ehuelsmann at common-lisp.net Sun Oct 3 09:09:28 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 03 Oct 2010 05:09:28 -0400 Subject: [armedbear-cvs] r12943 - trunk/abcl Message-ID: Author: ehuelsmann Date: Sun Oct 3 05:09:27 2010 New Revision: 12943 Log: Add the merge-back of the generic-class-file branch to CHANGES. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Sun Oct 3 05:09:27 2010 @@ -29,6 +29,13 @@ * [ticket #107] Incorrect compilation of (SETF STRUCTURE-REF) expansion +Other +----- + +* [svn r12918] Compiler byte code generator cleanup: introduction + of generic class file writer, elimination of special purpose code + in the compiler. + Version 0.22 ============ svn://common-lisp.net/project/armedbear/svn/tags/0.22.0/abcl From ehuelsmann at common-lisp.net Sun Oct 3 09:19:25 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 03 Oct 2010 05:19:25 -0400 Subject: [armedbear-cvs] r12944 - trunk/abcl/test/lisp/abcl Message-ID: Author: ehuelsmann Date: Sun Oct 3 05:19:24 2010 New Revision: 12944 Log: Fix tests: rename ":class-constructor" to ":static-initializer"; that's its new name. Modified: trunk/abcl/test/lisp/abcl/class-file.lisp Modified: trunk/abcl/test/lisp/abcl/class-file.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/class-file.lisp (original) +++ trunk/abcl/test/lisp/abcl/class-file.lisp Sun Oct 3 05:19:24 2010 @@ -166,7 +166,7 @@ (jvm::class-add-method file (jvm::make-method "MBC" nil :int)) (jvm::class-add-method file (jvm::make-method "MBD" nil jvm::+lisp-object+)) (jvm::class-add-method file (jvm::make-method :constructor :void nil)) - (jvm::class-add-method file (jvm::make-method :class-constructor :void nil)) + (jvm::class-add-method file (jvm::make-method :static-initializer :void nil)) T) T) @@ -187,7 +187,7 @@ (deftest generate-method.1 (let* ((class (jvm::make-class-name "org/armedbear/lisp/gm_1")) (file (jvm::make-class-file class jvm::+lisp-object+ '(:public))) - (method (jvm::make-method :class-constructor :void nil + (method (jvm::make-method :static-initializer :void nil :flags '(:static)))) (jvm::class-add-method file method) (jvm::with-code-to-method (file method) @@ -257,7 +257,7 @@ ) (jvm::class-add-field file (jvm::make-field "N1" jvm::+lisp-object+ :flags '(:static :private))) - (let ((method (jvm::make-method :class-constructor :void nil :flags '(:static)))) + (let ((method (jvm::make-method :static-initializer :void nil :flags '(:static)))) (jvm::class-add-method file method) (jvm::with-code-to-method (file method) (jvm::emit-getstatic jvm::+lisp+ "NIL" jvm::+lisp-object+) @@ -323,7 +323,7 @@ (deftest with-code-to-method.1 (let* ((class (jvm::make-class-name "org/armedbear/lisp/gm_6")) (file (jvm::make-class-file class jvm::+lisp-object+ '(:public))) - (method (jvm::make-method :class-constructor :void nil + (method (jvm::make-method :static-initializer :void nil :flags '(:static))) (registers nil)) (jvm::class-add-method file method) @@ -347,7 +347,7 @@ (deftest with-code-to-method.2 (let* ((class (jvm::make-class-name "org/armedbear/lisp/gm_7")) (file (jvm::make-class-file class jvm::+lisp-object+ '(:public))) - (method1 (jvm::make-method :class-constructor :void nil + (method1 (jvm::make-method :static-initializer :void nil :flags '(:static))) (method2 (jvm::make-method "method2" :void nil)) (registers nil)) From vvoutilainen at common-lisp.net Sun Oct 3 16:14:59 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 03 Oct 2010 12:14:59 -0400 Subject: [armedbear-cvs] r12945 - public_html Message-ID: Author: vvoutilainen Date: Sun Oct 3 12:14:55 2010 New Revision: 12945 Log: Add bug reporting instructions to the web pages. Added: public_html/bugreporting.shtml Modified: public_html/index.shtml Added: public_html/bugreporting.shtml ============================================================================== --- (empty file) +++ public_html/bugreporting.shtml Sun Oct 3 12:14:55 2010 @@ -0,0 +1,76 @@ + + + + + Bug reporting + + + + + +
+

Bug reporting

+
+ + + +
+ + + + + + + +

A quick guide to producing meaningful bug reports for ABCL

+ +This guide describes how to report bugs in ABCL. When you think you've +found a bug, send a bug report to the mailing list. For the bug report +to be most useful, try and do the following things: + +
    +
  1. + Use a descriptive subject, stating a brief summary of the bug, and + mentioning that you're reporting a bug. Don't be fussy about the format + of the subject, we don't process the bugs automatically, just try to + provide a meaningful description.
    2. +
  2. + Add a short program snippet that demonstrates what ABCL does incorrectly, + and if necessary, quote any relevant portions in the Common Lisp standard. +
    3. +
  3. + Differences between ABCL and other Common Lisp implementations are useful + information, if you find that some other Common Lisp implementation works + correctly and ABCL has a bug, it helps us in fixing the problem, so + try your program snippet on other implementations as well and post + the results. +
    4. +
  4. + Try and answer any questions asked about your bug report. +
    5. +
  5. + It is very much appreciated if you can actually find what's causing + the bug in ABCL codebase and even better still if you can produce + a patch that fixes the problem. Don't + fret if you can't, though, reports without patches are warmly welcomed, but + we highly appreciate patch contibutions. +
    6. +
+ +After all that, sit back, relax and enjoy yourself, the bug should +get fixed eventually. The maintainers of ABCL are usually rather +busy, but we will take a look at all bug reports when we have time. +
+
+
+

Back to Common-lisp.net.

+ +
+ Valid XHTML 1.0 Strict +
+
$Id: contributing.shtml 12008 2009-06-07 21:25:48Z ehuelsmann $
+
+ + + Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Sun Oct 3 12:14:55 2010 @@ -101,7 +101,7 @@
  • Documentation
  • Examples
  • Testimonials
    • -
  • Bug reporting
    • +
  • Bug reporting
    • From vvoutilainen at common-lisp.net Sun Oct 3 21:33:36 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 03 Oct 2010 17:33:36 -0400 Subject: [armedbear-cvs] r12946 - in trunk/abcl: src/org/armedbear/lisp test/lisp/ansi Message-ID: Author: vvoutilainen Date: Sun Oct 3 17:33:34 2010 New Revision: 12946 Log: Thread-safety fix for CLOS. Finding the problem and the patch by David Kirkman, kudos for the hard work. I merely added fixes for the other hashtables according to David's patch, and fixed the ansi error parsing, reported again by David. MASSIVE thanks for the patch! Modified: trunk/abcl/src/org/armedbear/lisp/EqHashTable.java trunk/abcl/src/org/armedbear/lisp/EqlHashTable.java trunk/abcl/src/org/armedbear/lisp/EqualHashTable.java trunk/abcl/src/org/armedbear/lisp/EqualpHashTable.java trunk/abcl/test/lisp/ansi/parse-ansi-errors.lisp Modified: trunk/abcl/src/org/armedbear/lisp/EqHashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/EqHashTable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/EqHashTable.java Sun Oct 3 17:33:34 2010 @@ -54,7 +54,7 @@ } @Override - public LispObject get(LispObject key) + public synchronized LispObject get(LispObject key) { final int index; if (key == cachedKey) { @@ -74,7 +74,7 @@ } @Override - public void put(LispObject key, LispObject value) + public synchronized void put(LispObject key, LispObject value) { int index; if (key == cachedKey) { Modified: trunk/abcl/src/org/armedbear/lisp/EqlHashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/EqlHashTable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/EqlHashTable.java Sun Oct 3 17:33:34 2010 @@ -55,7 +55,7 @@ } @Override - public LispObject get(LispObject key) + public synchronized LispObject get(LispObject key) { HashEntry e = buckets[key.sxhash() & mask]; while (e != null) @@ -68,7 +68,7 @@ } @Override - public void put(LispObject key, LispObject value) + public synchronized void put(LispObject key, LispObject value) { int index = key.sxhash() & mask; HashEntry e = buckets[index]; Modified: trunk/abcl/src/org/armedbear/lisp/EqualHashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/EqualHashTable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/EqualHashTable.java Sun Oct 3 17:33:34 2010 @@ -51,7 +51,7 @@ } @Override - public LispObject get(LispObject key) + public synchronized LispObject get(LispObject key) { HashEntry e = buckets[key.sxhash() & mask]; while (e != null) @@ -64,7 +64,7 @@ } @Override - public void put(LispObject key, LispObject value) + public synchronized void put(LispObject key, LispObject value) { int index = key.sxhash() & mask; HashEntry e = buckets[index]; Modified: trunk/abcl/src/org/armedbear/lisp/EqualpHashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/EqualpHashTable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/EqualpHashTable.java Sun Oct 3 17:33:34 2010 @@ -48,7 +48,7 @@ } @Override - public LispObject get(LispObject key) + public synchronized LispObject get(LispObject key) { final int index = key.psxhash() % buckets.length; HashEntry e = buckets[index]; @@ -62,7 +62,7 @@ } @Override - public void put(LispObject key, LispObject value) + public synchronized void put(LispObject key, LispObject value) { int index = key.psxhash() % buckets.length; HashEntry e = buckets[index]; Modified: trunk/abcl/test/lisp/ansi/parse-ansi-errors.lisp ============================================================================== --- trunk/abcl/test/lisp/ansi/parse-ansi-errors.lisp (original) +++ trunk/abcl/test/lisp/ansi/parse-ansi-errors.lisp Sun Oct 3 17:33:34 2010 @@ -76,7 +76,7 @@ (defvar *default-database-file* (if (find :asdf2 *features*) (asdf:system-relative-pathname :ansi-compiled "test/lisp/ansi/ansi-test-failures") - (merge-pathnames "ansi-test-failures" (directory-namestring *load-truename*))) + (merge-pathnames "ansi-test-failures" (directory-namestring *load-truename*)))) (defun parse (&optional (file *default-database-file*)) (format t "Parsing test report database from ~A~%" *default-database-file*) From ehuelsmann at common-lisp.net Sun Oct 3 21:39:44 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 03 Oct 2010 17:39:44 -0400 Subject: [armedbear-cvs] r12947 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Oct 3 17:39:43 2010 New Revision: 12947 Log: Fix ZIP on Windows; in some ABCL lisp tests, it thinks we're trying to add the same entry multiple times, because it doesn't recognize the directories. (We use forward slashes as component separators now.) Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/src/org/armedbear/lisp/zip.java Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Sun Oct 3 17:39:43 2010 @@ -52,6 +52,11 @@ public class Pathname extends LispObject { + /** The path component separator used by internally generated + * path namestrings. + */ + public final static char separator = '/'; + protected LispObject host = NIL; protected LispObject device = NIL; protected LispObject directory = NIL; Modified: trunk/abcl/src/org/armedbear/lisp/zip.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/zip.java (original) +++ trunk/abcl/src/org/armedbear/lisp/zip.java Sun Oct 3 17:39:43 2010 @@ -130,9 +130,9 @@ String d = dir.substring(rootPathLength); int i = 0; int j; - while ((j = d.indexOf(File.separator, i)) != -1) { + while ((j = d.indexOf(Pathname.separator, i)) != -1) { i = j + 1; - directory = d.substring(0, j).replace(File.separatorChar, '/') + "/"; + directory = d.substring(0, j) + Pathname.separator; if (!directories.contains(directory)) { directories.add(directory); ZipEntry entry = new ZipEntry(directory); From ehuelsmann at common-lisp.net Sun Oct 3 21:42:10 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 03 Oct 2010 17:42:10 -0400 Subject: [armedbear-cvs] r12948 - trunk/abcl/test/lisp/abcl Message-ID: Author: ehuelsmann Date: Sun Oct 3 17:42:09 2010 New Revision: 12948 Log: Fix test expectations due to us now generating forward slashes in our printed pathnames, even on Windows. Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp trunk/abcl/test/lisp/abcl/pathname-tests.lisp Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/jar-pathname.lisp (original) +++ trunk/abcl/test/lisp/abcl/jar-pathname.lisp Sun Oct 3 17:42:09 2010 @@ -57,9 +57,9 @@ (cl-fad-copy-file (merge-pathnames "eek.lisp") (merge-pathnames "eek.lisp" sub)) (sys:zip (merge-pathnames "baz.jar") - (append - (directory (merge-pathnames "*" dir)) - (directory (merge-pathnames "*" sub))) + (print (append + (directory (merge-pathnames "*" dir)) + (directory (merge-pathnames "*" sub)))) dir) (delete-directory-and-files dir))) (setf *jar-file-init* t)) Modified: trunk/abcl/test/lisp/abcl/pathname-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/pathname-tests.lisp (original) +++ trunk/abcl/test/lisp/abcl/pathname-tests.lisp Sun Oct 3 17:42:09 2010 @@ -99,8 +99,10 @@ (declare (type string expected)) (let ((result (namestring (apply 'translate-pathname args)))) (equal result - #-windows expected - #+windows (substitute #\\ #\/ expected)))) + ;;#-windows + expected + ;;#+windows (substitute #\\ #\/ expected) + ))) (defmacro check-readable (pathname) `(equal ,pathname (read-from-string (write-to-string ,pathname :readably t)))) @@ -112,8 +114,9 @@ (defmacro check-namestring (pathname namestring) `(string= (namestring ,pathname) - #+windows (substitute #\\ #\/ ,namestring) - #-windows ,namestring)) + ;;#+windows (substitute #\\ #\/ ,namestring) + ;;#-windows + ,namestring)) ;; Define a logical host. (setf (logical-pathname-translations "effluvia") @@ -307,10 +310,8 @@ (pushnew 'namestring.2 *expected-failures*) (deftest directory-namestring.1 - (equal (directory-namestring #-windows #p"./" - #+windows #p".\\") - #-windows "./" - #+windows ".\\") + (equal (directory-namestring #p"./") + "./") t) #+lispworks (pushnew 'directory-namestring.1 *expected-failures*) @@ -384,8 +385,7 @@ (deftest directory-namestring.2 (equal (directory-namestring #-windows #p"../" #+windows #p"..\\") - #-windows "../" - #+windows "..\\") + "../") t) #-sbcl @@ -402,8 +402,7 @@ (deftest physical.31 (string= (namestring (make-pathname :directory '(:relative :up))) - #+windows "..\\" - #-windows "../") + "../") t) #+windows @@ -918,8 +917,7 @@ (deftest translate-pathname.12 (string= (namestring (translate-pathname "foo.bar" "*.*" "/usr/local/*.*")) - #-windows "/usr/local/foo.bar" - #+windows "\\usr\\local\\foo.bar") + "/usr/local/foo.bar") t) (deftest translate-pathname.13 @@ -1118,7 +1116,7 @@ #-windows (equal (enough-namestring #p"foo/bar" #p"foo") "foo/bar") #+windows - (equal (enough-namestring #p"foo\\bar" #p"foo") "foo\\bar") + (equal (enough-namestring #p"foo\\bar" #p"foo") "foo/bar") t) (deftest enough-namestring.3 @@ -1251,8 +1249,10 @@ (signals-error (translate-logical-pathname "demo0:x.y") 'error) #-clisp (equal (namestring (translate-logical-pathname "demo0:x.y")) - #-windows "/tmp/x.y" - #+windows "\\tmp\\x.y") + ;;#-windows + "/tmp/x.y" + ;;#+windows "\\tmp\\x.y" + ) t) #-(or allegro clisp) @@ -1626,29 +1626,36 @@ #-allegro (deftest sbcl.59 (string= (with-standard-io-syntax (write-to-string #p"/foo")) - #-windows "#P\"/foo\"" - #+(and windows (not lispworks)) "#P\"\\\\foo\"" - #+(and windows lispworks) "#P\"/foo\"") + ;;#-windows "#P\"/foo\"" + ;;#+(and windows (not lispworks)) "#P\"\\\\foo\"" + ;;#+(and windows lispworks) + "#P\"/foo\"") t) #-allegro (deftest sbcl.60 (string= (with-standard-io-syntax (write-to-string #p"/foo" :readably nil)) - #-windows "#P\"/foo\"" - #+(and windows (not lispworks)) "#P\"\\\\foo\"" - #+(and windows lispworks) "#P\"/foo\"") + ;;#-windows + "#P\"/foo\"" + ;;#+(and windows (not lispworks)) "#P\"\\\\foo\"" + ;;#+(and windows lispworks) "#P\"/foo\"" + ) t) #-allegro (deftest sbcl.61 (string= (with-standard-io-syntax (write-to-string #p"/foo" :escape nil)) - #-windows "#P\"/foo\"" - #+(and windows (not lispworks)) "#P\"\\\\foo\"" - #+(and windows lispworks) "#P\"/foo\"") + ;;#-windows + "#P\"/foo\"" + ;;#+(and windows (not lispworks)) "#P\"\\\\foo\"" + ;;#+(and windows lispworks) "#P\"/foo\"" + ) t) (deftest sbcl.62 (string= (with-standard-io-syntax (write-to-string #p"/foo" :readably nil :escape nil)) - #-windows "/foo" - #+windows "\\foo") + ;;#-windows + "/foo" + ;;#+windows "\\foo" + ) t) From ehuelsmann at common-lisp.net Mon Oct 4 06:59:27 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 04 Oct 2010 02:59:27 -0400 Subject: [armedbear-cvs] r12949 - trunk/abcl/test/lisp/abcl Message-ID: Author: ehuelsmann Date: Mon Oct 4 02:59:23 2010 New Revision: 12949 Log: Remove debug print. Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/jar-pathname.lisp (original) +++ trunk/abcl/test/lisp/abcl/jar-pathname.lisp Mon Oct 4 02:59:23 2010 @@ -57,9 +57,9 @@ (cl-fad-copy-file (merge-pathnames "eek.lisp") (merge-pathnames "eek.lisp" sub)) (sys:zip (merge-pathnames "baz.jar") - (print (append - (directory (merge-pathnames "*" dir)) - (directory (merge-pathnames "*" sub)))) + (append + (directory (merge-pathnames "*" dir)) + (directory (merge-pathnames "*" sub))) dir) (delete-directory-and-files dir))) (setf *jar-file-init* t)) From ehuelsmann at common-lisp.net Mon Oct 4 10:11:16 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 04 Oct 2010 06:11:16 -0400 Subject: [armedbear-cvs] r12950 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Oct 4 06:11:13 2010 New Revision: 12950 Log: Add two functions to disable signalling of over- and underflow conditions in floating point calculations; working toward CLHS compliance while keeping Maxima fixed (it was, as of last weekend). Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/Symbol.java Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Mon Oct 4 06:11:13 2010 @@ -5777,4 +5777,50 @@ } }; + /* Added to ABCL because Maxima wants to be able to turn off + * underflow conditions. However, the Hyperspec says we have to + * signal them. So, we went for CLHS compliant with a switch for + * Maxima. + */ + // ### float-underflow-mode + private static final Primitive FLOAT_UNDERFLOW_MODE + = new pf_float_underflow_mode(); + private static final class pf_float_underflow_mode extends Primitive { + pf_float_underflow_mode() { + super(Symbol.FLOAT_UNDERFLOW_MODE, "&optional boolean"); + } + + @Override + public LispObject execute() { + return Lisp.TRAP_UNDERFLOW ? T : NIL; + } + + @Override + public LispObject execute(LispObject arg) { + Lisp.TRAP_UNDERFLOW = (arg != NIL); + return arg; + } + }; + + /* Implemented for symmetry with the underflow variant. */ + // ### float-overflow-mode + private static final Primitive FLOAT_OVERFLOW_MODE + = new pf_float_overflow_mode(); + private static final class pf_float_overflow_mode extends Primitive { + pf_float_overflow_mode() { + super(Symbol.FLOAT_OVERFLOW_MODE, "&optional boolean"); + } + + @Override + public LispObject execute() { + return Lisp.TRAP_OVERFLOW ? T : NIL; + } + + @Override + public LispObject execute(LispObject arg) { + Lisp.TRAP_OVERFLOW = (arg != NIL); + return arg; + } + }; + } Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Mon Oct 4 06:11:13 2010 @@ -2982,6 +2982,10 @@ PACKAGE_SYS.addExternalSymbol("ENVIRONMENT"); public static final Symbol FORWARD_REFERENCED_CLASS = PACKAGE_SYS.addExternalSymbol("FORWARD-REFERENCED-CLASS"); + public static final Symbol FLOAT_UNDERFLOW_MODE = + PACKAGE_SYS.addExternalSymbol("FLOAT-UNDERFLOW-MODE"); + public static final Symbol FLOAT_OVERFLOW_MODE = + PACKAGE_SYS.addExternalSymbol("FLOAT-OVERFLOW-MODE"); public static final Symbol CLASS_BYTES = PACKAGE_SYS.addExternalSymbol("CLASS-BYTES"); public static final Symbol _CLASS_SLOTS = From ehuelsmann at common-lisp.net Mon Oct 4 13:11:13 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 04 Oct 2010 09:11:13 -0400 Subject: [armedbear-cvs] r12951 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Oct 4 09:11:12 2010 New Revision: 12951 Log: Signal a condition when coercing a Ratio to any float type or when coercing a double-float to a single-float where the original value is too big to fit the target type. Modified: trunk/abcl/src/org/armedbear/lisp/Ratio.java trunk/abcl/src/org/armedbear/lisp/SingleFloat.java Modified: trunk/abcl/src/org/armedbear/lisp/Ratio.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Ratio.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Ratio.java Mon Oct 4 09:11:12 2010 @@ -181,6 +181,10 @@ @Override public float floatValue() { + float result = (float) doubleValue(); + if (Float.isInfinite(result) && TRAP_OVERFLOW) + type_error(this, Symbol.SINGLE_FLOAT); + return (float) doubleValue(); } @@ -217,6 +221,9 @@ n = n.shiftRight(1); d = d.shiftRight(1); } + if (Double.isInfinite(result) && TRAP_OVERFLOW) + type_error(this, Symbol.DOUBLE_FLOAT); + return negative ? -result : result; } Modified: trunk/abcl/src/org/armedbear/lisp/SingleFloat.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SingleFloat.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SingleFloat.java Mon Oct 4 09:11:12 2010 @@ -629,8 +629,13 @@ return new SingleFloat(((Fixnum)obj).value); if (obj instanceof SingleFloat) return (SingleFloat) obj; - if (obj instanceof DoubleFloat) - return new SingleFloat((float)((DoubleFloat)obj).value); + if (obj instanceof DoubleFloat) { + float result = (float)((DoubleFloat)obj).value; + if (Float.isInfinite(result) && TRAP_OVERFLOW) + type_error(obj, Symbol.SINGLE_FLOAT); + + return new SingleFloat(result); + } if (obj instanceof Bignum) return new SingleFloat(((Bignum)obj).floatValue()); if (obj instanceof Ratio) From ehuelsmann at common-lisp.net Mon Oct 4 14:31:11 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 04 Oct 2010 10:31:11 -0400 Subject: [armedbear-cvs] r12952 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Oct 4 10:31:10 2010 New Revision: 12952 Log: Maxima disables underflow signals itself now. We default back to signalling in order to pass CLHS ANSI tests. Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Mon Oct 4 10:31:10 2010 @@ -2704,7 +2704,7 @@ // Floating point traps. protected static boolean TRAP_OVERFLOW = true; - protected static boolean TRAP_UNDERFLOW = false; + protected static boolean TRAP_UNDERFLOW = true; // Extentions From astalla at common-lisp.net Wed Oct 6 22:03:59 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Wed, 06 Oct 2010 18:03:59 -0400 Subject: [armedbear-cvs] r12953 - branches/invokedynamic/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Wed Oct 6 18:03:56 2010 New Revision: 12953 Log: invokedynamic: support for the new typechecking verifier (half-way, compilation broken!) Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/JavaClassLoader.java branches/invokedynamic/abcl/src/org/armedbear/lisp/Main.java branches/invokedynamic/abcl/src/org/armedbear/lisp/compile-system.lisp branches/invokedynamic/abcl/src/org/armedbear/lisp/compiler-pass2.lisp branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/JavaClassLoader.java ============================================================================== --- branches/invokedynamic/abcl/src/org/armedbear/lisp/JavaClassLoader.java (original) +++ branches/invokedynamic/abcl/src/org/armedbear/lisp/JavaClassLoader.java Wed Oct 6 18:03:56 2010 @@ -117,13 +117,13 @@ resolveClass(c); return c; } - } - catch (VerifyError e) - { + } catch (VerifyError e) { error(new LispError("Class verification failed: " + e.getMessage())); - } - catch (Throwable t) { + } catch (Throwable t) { + Debug.trace("Classloading error for " + className); Debug.trace(t); + LispThread.currentThread().printBacktrace(); + Debug.trace("Classloading error for " + className); } return null; } Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/Main.java ============================================================================== --- branches/invokedynamic/abcl/src/org/armedbear/lisp/Main.java (original) +++ branches/invokedynamic/abcl/src/org/armedbear/lisp/Main.java Wed Oct 6 18:03:56 2010 @@ -40,7 +40,7 @@ { public static final long startTimeMillis = System.currentTimeMillis(); - static { Linkage.registerBootstrapMethod(Function.class, "linkLispFunction"); } + // static { Linkage.registerBootstrapMethod(Function.class, "linkLispFunction"); } public static void main(final String[] args) { @@ -56,16 +56,16 @@ } }; new Thread(null, r, "interpreter", 4194304L).start(); - try { + /*try { for(int i = 0; i < 2; i++) { Thread.sleep(5000); InvokeDynamic.#"COMMON-LISP:PRINT"((LispObject) new SimpleString("foo")); InvokeDynamic.#"COMMON-LISP:PRINT"((LispObject) new SimpleString("bar")); - InvokeDynamic.#"CL-USER::FOO"((LispObject) new SimpleString("baz")); + // InvokeDynamic.#"CL-USER::FOO"((LispObject) new SimpleString("baz")); } } catch(Throwable t) { t.printStackTrace(); - } + }*/ //java.dyn.InvokeDynamic.foo(new SimpleString("foo")); } } Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- branches/invokedynamic/abcl/src/org/armedbear/lisp/compile-system.lisp (original) +++ branches/invokedynamic/abcl/src/org/armedbear/lisp/compile-system.lisp Wed Oct 6 18:03:56 2010 @@ -270,24 +270,29 @@ t)) (defun compile-system (&key quit (zip t) output-path) - (let ((status -1)) - (check-lisp-home) - (time - (with-compilation-unit () - (let ((*compile-file-zip* zip) - failure-p) - (handler-bind (((or warning - compiler-error) - #'(lambda (c) - (declare (ignore c)) - (setf failure-p t) - ;; only register that we had this type of signal - ;; defer the actual handling to another handler - nil))) - (%compile-system :output-path output-path)) - (unless failure-p - (setf status 0))))) - (create-system-logical-translations output-path) + (let ((status -1) failure) + (handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (let ((*print-circle* t)) + (pprint (sys::backtrace-as-list))) + nil))) + (check-lisp-home) + (time + (with-compilation-unit () + (let ((*compile-file-zip* zip)) + (handler-bind (((or warning + compiler-error) + #'(lambda (c) + (setf failure c) + ;; only register that we had this type of signal + ;; defer the actual handling to another handler + nil))) + (%compile-system :output-path output-path)) + (unless failure + (setf status 0))))) + (create-system-logical-translations output-path)) + (when failure + (format t "Failure: ~A~%" failure)) (when quit (quit :status status)))) Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/invokedynamic/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/invokedynamic/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed Oct 6 18:03:56 2010 @@ -204,8 +204,9 @@ (declaim (ftype (function * t) emit-invokestatic)) (defun emit-invokestatic (class-name method-name arg-types return-type) (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types)) - (index (pool-add-method-ref *pool* class-name - method-name (cons return-type arg-types))) + (index (constant-index (pool-add-method-ref + *pool* class-name + method-name (cons return-type arg-types)))) (instruction (apply #'%emit 'invokestatic (u2 index)))) (setf (instruction-stack instruction) stack-effect))) @@ -225,8 +226,9 @@ (defknown emit-invokevirtual (t t t t) t) (defun emit-invokevirtual (class-name method-name arg-types return-type) (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types)) - (index (pool-add-method-ref *pool* class-name - method-name (cons return-type arg-types))) + (index (constant-index (pool-add-method-ref + *pool* class-name + method-name (cons return-type arg-types)))) (instruction (apply #'%emit 'invokevirtual (u2 index)))) (declare (type (signed-byte 8) stack-effect)) (let ((explain *explain*)) @@ -242,8 +244,9 @@ (defknown emit-invokespecial-init (string list) t) (defun emit-invokespecial-init (class-name arg-types) (let* ((stack-effect (apply #'descriptor-stack-effect :void arg-types)) - (index (pool-add-method-ref *pool* class-name - "" (cons nil arg-types))) + (index (constant-index (pool-add-method-ref + *pool* class-name + "" (cons nil arg-types)))) (instruction (apply #'%emit 'invokespecial (u2 index)))) (declare (type (signed-byte 8) stack-effect)) (setf (instruction-stack instruction) (1- stack-effect)))) @@ -283,42 +286,42 @@ (declaim (inline emit-getstatic emit-putstatic)) (defknown emit-getstatic (t t t) t) (defun emit-getstatic (class-name field-name type) - (let ((index (pool-add-field-ref *pool* class-name field-name type))) - (apply #'%emit 'getstatic (u2 index)))) + (let ((ref (pool-add-field-ref *pool* class-name field-name type))) + (apply #'%emit 'getstatic (u2 (constant-index ref))))) (defknown emit-putstatic (t t t) t) (defun emit-putstatic (class-name field-name type) - (let ((index (pool-add-field-ref *pool* class-name field-name type))) - (apply #'%emit 'putstatic (u2 index)))) + (let ((ref (pool-add-field-ref *pool* class-name field-name type))) + (apply #'%emit 'putstatic (u2 (constant-index ref))))) (declaim (inline emit-getfield emit-putfield)) (defknown emit-getfield (t t t) t) (defun emit-getfield (class-name field-name type) - (let* ((index (pool-add-field-ref *pool* class-name field-name type))) - (apply #'%emit 'getfield (u2 index)))) + (let* ((ref (pool-add-field-ref *pool* class-name field-name type))) + (apply #'%emit 'getfield (u2 (constant-index ref))))) (defknown emit-putfield (t t t) t) (defun emit-putfield (class-name field-name type) - (let* ((index (pool-add-field-ref *pool* class-name field-name type))) - (apply #'%emit 'putfield (u2 index)))) + (let* ((ref (pool-add-field-ref *pool* class-name field-name type))) + (apply #'%emit 'putfield (u2 (constant-index ref))))) (defknown emit-new (t) t) (declaim (inline emit-new emit-anewarray emit-checkcast emit-instanceof)) (defun emit-new (class-name) - (apply #'%emit 'new (u2 (pool-class class-name)))) + (apply #'%emit 'new (u2 (constant-index (pool-class class-name))))) (defknown emit-anewarray (t) t) (defun emit-anewarray (class-name) - (apply #'%emit 'anewarray (u2 (pool-class class-name)))) + (apply #'%emit 'anewarray (u2 (constant-index (pool-class class-name))))) (defknown emit-checkcast (t) t) (defun emit-checkcast (class-name) - (apply #'%emit 'checkcast (u2 (pool-class class-name)))) + (apply #'%emit 'checkcast (u2 (constant-index (pool-class class-name))))) (defknown emit-instanceof (t) t) (defun emit-instanceof (class-name) - (apply #'%emit 'instanceof (u2 (pool-class class-name)))) + (apply #'%emit 'instanceof (u2 (constant-index (pool-class class-name))))) (defvar type-representations '((:int fixnum) @@ -907,6 +910,24 @@ method)) +(defun make-static-initializer () + (let* ((*compiler-debug* nil) + ;; We don't normally need to see debugging output for . + (method (make-method :static-initializer + :void nil :flags '(:public :static))) + (code (method-add-code method)) + (*code* ()) + (*current-code-attribute* code)) + (setf (code-max-locals code) 1) + (emit 'ldc (pool-class +lisp-function+)) + (emit 'ldc (pool-string "linkLispFunction")) + (emit-invokestatic +dyn-linkage+ "registerBootstrapMethod" + (list +java-class+ +java-string+) :void) + ;(setf *code* (append *static-code* *code*)) + (emit 'return) + (setf (code-code code) *code*) + method)) + (defvar *source-line-number* nil) @@ -918,10 +939,10 @@ (class-add-method class (make-constructor (class-file-superclass class) (abcl-class-file-lambda-name class) (abcl-class-file-lambda-list class))) + (class-add-method class (make-static-initializer)) (finalize-class-file class) (write-class-file class stream)) - (defknown declare-field (t t t) t) (defun declare-field (name descriptor) (let ((field (make-field name descriptor Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Wed Oct 6 18:03:56 2010 @@ -133,7 +133,10 @@ (define-class-name +java-object+ "java.lang.Object") (define-class-name +java-string+ "java.lang.String") (define-class-name +java-system+ "java.lang.System") +(define-class-name +java-class+ "java.lang.Class") (define-class-name +lisp-object+ "org.armedbear.lisp.LispObject") +(define-class-name +dyn-linkage+ "java.dyn.Linkage") +(define-class-name +dyn-invokedynamic+ "java.dyn.InvokeDynamic") (defconstant +lisp-object-array+ (class-array +lisp-object+)) (define-class-name +lisp-simple-string+ "org.armedbear.lisp.SimpleString") (define-class-name +lisp+ "org.armedbear.lisp.Lisp") @@ -167,6 +170,7 @@ (define-class-name +lisp-return+ "org.armedbear.lisp.Return") (define-class-name +lisp-go+ "org.armedbear.lisp.Go") (define-class-name +lisp-primitive+ "org.armedbear.lisp.Primitive") +(define-class-name +lisp-function+ "org.armedbear.lisp.Function") (define-class-name +lisp-eql-hash-table+ "org.armedbear.lisp.EqlHashTable") (define-class-name +lisp-hash-table+ "org.armedbear.lisp.HashTable") (define-class-name +lisp-package+ "org.armedbear.lisp.Package") @@ -276,6 +280,9 @@ (:name-and-type 12 1) (:utf8 1 1))) +(defun constant-type (constant) + (car (find (constant-tag constant) +constant-type-map+ :key #'cadr))) + (defstruct (constant-class (:constructor make-constant-class (index name-index)) (:include constant (tag 7))) @@ -367,20 +374,20 @@ (defun pool-add-class (pool class) - "Returns the index of the constant-pool class item for `class'. + "Returns the constant-pool class item for `class'. `class' must be an instance of `class-name'." (let ((entry (gethash class (pool-entries pool)))) (unless entry - (let ((utf8 (pool-add-utf8 pool (class-name-internal class)))) + (let ((utf8 (constant-index (pool-add-utf8 pool (class-name-internal class))))) (setf entry (make-constant-class (incf (pool-index pool)) utf8) (gethash class (pool-entries pool)) entry)) (push entry (pool-entries-list pool))) - (constant-index entry))) + entry)) (defun pool-add-field-ref (pool class name type) - "Returns the index of the constant-pool item which denotes a reference + "Returns the constant-pool item which denotes a reference to the `name' field of the `class', being of `type'. `class' should be an instance of `class-name'. @@ -388,85 +395,86 @@ `type' is a field-type (see `internal-field-type')" (let ((entry (gethash (acons name type class) (pool-entries pool)))) (unless entry - (let ((c (pool-add-class pool class)) - (n/t (pool-add-name/type pool name type))) + (let ((c (constant-index (pool-add-class pool class))) + (n/t (constant-index (pool-add-name/type pool name type)))) (setf entry (make-constant-field-ref (incf (pool-index pool)) c n/t) (gethash (acons name type class) (pool-entries pool)) entry)) (push entry (pool-entries-list pool))) - (constant-index entry))) + entry)) (defun pool-add-method-ref (pool class name type) - "Returns the index of the constant-pool item which denotes a reference + "Returns the constant-pool item which denotes a reference to the method with `name' in `class', which is of `type'. Here, `type' is a method descriptor, which defines the argument types and return type. `class' is an instance of `class-name'." (let ((entry (gethash (acons name type class) (pool-entries pool)))) (unless entry - (let ((c (pool-add-class pool class)) - (n/t (pool-add-name/type pool name type))) + (let ((c (constant-index (pool-add-class pool class))) + (n/t (constant-index (pool-add-name/type pool name type)))) (setf entry (make-constant-method-ref (incf (pool-index pool)) c n/t) (gethash (acons name type class) (pool-entries pool)) entry)) (push entry (pool-entries-list pool))) - (constant-index entry))) + entry)) (defun pool-add-interface-method-ref (pool class name type) - "Returns the index of the constant-pool item which denotes a reference to + "Returns the constant-pool item which denotes a reference to the method `name' in the interface `class', which is of `type'. See `pool-add-method-ref' for remarks." (let ((entry (gethash (acons name type class) (pool-entries pool)))) (unless entry - (let ((c (pool-add-class pool class)) - (n/t (pool-add-name/type pool name type))) + (let ((c (constant-index (pool-add-class pool class))) + (n/t (constant-index (pool-add-name/type pool name type)))) (setf entry (make-constant-interface-method-ref (incf (pool-index pool)) c n/t) (gethash (acons name type class) (pool-entries pool)) entry)) (push entry (pool-entries-list pool))) - (constant-index entry))) + entry)) (defun pool-add-string (pool string) - "Returns the index of the constant-pool item denoting the string." + "Returns the constant-pool item denoting the string." (let ((entry (gethash (cons 8 string) ;; 8 == string-tag (pool-entries pool)))) (unless entry (let ((utf8 (pool-add-utf8 pool string))) - (setf entry (make-constant-string (incf (pool-index pool)) utf8) + (setf entry (make-constant-string (incf (pool-index pool)) + (constant-index utf8)) (gethash (cons 8 string) (pool-entries pool)) entry)) (push entry (pool-entries-list pool))) - (constant-index entry))) + entry)) (defun pool-add-int (pool int) - "Returns the index of the constant-pool item denoting the int." + "Returns the constant-pool item denoting the int." (let ((entry (gethash (cons 3 int) (pool-entries pool)))) (unless entry (setf entry (make-constant-int (incf (pool-index pool)) int) (gethash (cons 3 int) (pool-entries pool)) entry) (push entry (pool-entries-list pool))) - (constant-index entry))) + entry)) (defun pool-add-float (pool float) - "Returns the index of the constant-pool item denoting the float." + "Returns the constant-pool item denoting the float." (let ((entry (gethash (cons 4 float) (pool-entries pool)))) (unless entry (setf entry (make-constant-float (incf (pool-index pool)) (sys::%float-bits float)) (gethash (cons 4 float) (pool-entries pool)) entry) (push entry (pool-entries-list pool))) - (constant-index entry))) + entry)) (defun pool-add-long (pool long) - "Returns the index of the constant-pool item denoting the long." + "Returns the constant-pool item denoting the long." (let ((entry (gethash (cons 5 long) (pool-entries pool)))) (unless entry (setf entry (make-constant-long (incf (pool-index pool)) long) (gethash (cons 5 long) (pool-entries pool)) entry) (push entry (pool-entries-list pool)) (incf (pool-index pool))) ;; double index increase; long takes 2 slots - (constant-index entry))) + entry)) (defun pool-add-double (pool double) - "Returns the index of the constant-pool item denoting the double." + "Returns constant-pool item denoting the double." (let ((entry (gethash (cons 6 double) (pool-entries pool)))) (unless entry (setf entry (make-constant-double (incf (pool-index pool)) @@ -474,38 +482,38 @@ (gethash (cons 6 double) (pool-entries pool)) entry) (push entry (pool-entries-list pool)) (incf (pool-index pool))) ;; double index increase; 'double' takes 2 slots - (constant-index entry))) + entry)) (defun pool-add-name/type (pool name type) - "Returns the index of the constant-pool item denoting -the name/type identifier." + "Returns the constant-pool item denoting the name/type identifier." (let ((entry (gethash (cons name type) (pool-entries pool))) (internal-type (if (listp type) (apply #'descriptor type) (internal-field-ref type)))) (unless entry - (let ((n (pool-add-utf8 pool name)) - (i-t (pool-add-utf8 pool internal-type))) + (let ((n (constant-index (pool-add-utf8 pool name))) + (i-t (constant-index (pool-add-utf8 pool internal-type)))) (setf entry (make-constant-name/type (incf (pool-index pool)) n i-t) (gethash (cons name type) (pool-entries pool)) entry)) (push entry (pool-entries-list pool))) - (constant-index entry))) + entry)) (defun pool-add-utf8 (pool utf8-as-string) - "Returns the index of the textual value that will be stored in the -class file as UTF-8 encoded data." + "Returns the textual value that will be stored in the class file as UTF-8 encoded data." (let ((entry (gethash (cons 11 utf8-as-string) ;; 11 == utf8 (pool-entries pool)))) (unless entry (setf entry (make-constant-utf8 (incf (pool-index pool)) utf8-as-string) (gethash (cons 11 utf8-as-string) (pool-entries pool)) entry) (push entry (pool-entries-list pool))) - (constant-index entry))) + entry)) (defstruct (class-file (:constructor make-class-file (class superclass access-flags))) "Holds the components of a class file." (constants (make-pool)) + (major-version 51) + (minor-version 0) access-flags class superclass @@ -567,11 +575,11 @@ (setf (class-file-access-flags class) (map-flags (class-file-access-flags class))) (setf (class-file-superclass class) - (pool-add-class (class-file-constants class) - (class-file-superclass class)) + (constant-index (pool-add-class (class-file-constants class) + (class-file-superclass class))) (class-file-class class) - (pool-add-class (class-file-constants class) - (class-file-class class))) + (constant-index (pool-add-class (class-file-constants class) + (class-file-class class)))) ;; (finalize-interfaces) (dolist (field (class-file-fields class)) (finalize-field field class)) @@ -667,8 +675,8 @@ ;; header (write-u4 #xCAFEBABE stream) - (write-u2 3 stream) - (write-u2 45 stream) + (write-u2 (class-file-minor-version class) stream) + (write-u2 (class-file-major-version class) stream) ;; constants pool (write-constants (class-file-constants class) stream) @@ -820,9 +828,9 @@ (setf (field-access-flags field) (map-flags (field-access-flags field)) (field-descriptor field) - (pool-add-utf8 pool (internal-field-ref (field-descriptor field))) + (constant-index (pool-add-utf8 pool (internal-field-ref (field-descriptor field)))) (field-name field) - (pool-add-utf8 pool (field-name field)))) + (constant-index (pool-add-utf8 pool (field-name field))))) (finalize-attributes (field-attributes field) nil class)) (defun write-field (field stream) @@ -897,9 +905,9 @@ (setf (method-access-flags method) (map-flags (method-access-flags method)) (method-descriptor method) - (pool-add-utf8 pool (apply #'descriptor (method-descriptor method))) + (constant-index (pool-add-utf8 pool (apply #'descriptor (method-descriptor method)))) (method-name method) - (pool-add-utf8 pool (method-name method)))) + (constant-index (pool-add-utf8 pool (method-name method))))) (finalize-attributes (method-attributes method) nil class)) @@ -929,8 +937,8 @@ (dolist (attribute attributes) ;; assure header: make sure 'name' is in the pool (setf (attribute-name attribute) - (pool-add-utf8 (class-file-constants class) - (attribute-name attribute))) + (constant-index (pool-add-utf8 (class-file-constants class) + (attribute-name attribute)))) ;; we're saving "root" attributes: attributes which have no parent (funcall (attribute-finalizer attribute) attribute att class))) @@ -968,7 +976,9 @@ ;; labels contains offsets into the code array after it's finalized labels ;; an alist - (current-local 0)) ;; used for handling nested WITH-CODE-TO-METHOD blocks + ;; these two are used for handling nested WITH-CODE-TO-METHOD blocks + (current-local 0) + stack-map-frames) @@ -985,7 +995,6 @@ (defun finalize-code-attribute (code parent class) "Prepares the `code' attribute for serialization, within method `parent'." - (declare (ignore parent)) (let* ((handlers (code-exception-handlers code)) (c (finalize-code (code-code code) @@ -999,6 +1008,8 @@ (unless (code-max-locals code) (setf (code-max-locals code) (analyze-locals code))) + (when (>= (class-file-major-version class) 50) + (code-add-attribute code (compute-stack-map-table class parent))) (multiple-value-bind (c labels) (code-bytes c) @@ -1021,8 +1032,8 @@ (exception-catch-type exception) (if (null (exception-catch-type exception)) 0 ;; generic 'catch all' class index number - (pool-add-class (class-file-constants class) - (exception-catch-type exception))))) + (constant-index (pool-add-class (class-file-constants class) + (exception-catch-type exception)))))) (finalize-attributes (code-attributes code) code class)) @@ -1117,8 +1128,8 @@ "Prepare `checked-exceptions' for serialization." (setf (checked-table checked-exceptions) (mapcar #'(lambda (exception) - (pool-add-class (class-file-constants class) - exception)) + (constant-index (pool-add-class (class-file-constants class) + exception))) (checked-table checked-exceptions)))) (defun write-checked-exceptions (checked-exceptions stream) @@ -1182,8 +1193,8 @@ (defun finalize-source-file (source-file code class) (declare (ignorable code class)) (setf (source-filename source-file) - (pool-add-utf8 (class-file-constants class) - (source-filename source-file)))) + (constant-index (pool-add-utf8 (class-file-constants class) + (source-filename source-file))))) (defun write-source-file (source-file stream) (write-u2 (source-filename source-file) stream)) @@ -1258,11 +1269,11 @@ (- (code-label-offset code (local-length local-variable)) (local-start-pc local-variable)) (local-name local-variable) - (pool-add-utf8 (class-file-constants class) - (local-name local-variable)) + (constant-index (pool-add-utf8 (class-file-constants class) + (local-name local-variable))) (local-descriptor local-variable) - (pool-add-utf8 (class-file-constants class) - (local-descriptor local-variable))))) + (constant-index (pool-add-utf8 (class-file-constants class) + (local-descriptor local-variable)))))) (defun write-local-variables (local-variables stream) (write-u2 (length (local-var-table local-variables)) stream) @@ -1273,6 +1284,364 @@ (write-u2 (local-descriptor local-variable) stream) (write-u2 (local-index local-variable) stream))) +;;Support for the StackMapTable attribute used by the typechecking verifier +;;from class file version number 50.0 onward (astalla) + +(defstruct (stack-map-table-attribute + (:conc-name stack-map-table-) + (:include attribute + (name "StackMapTable") + (finalizer #'finalize-stack-map-table-attribute) + (writer #'write-stack-map-table-attribute))) + ;(:constructor %make-stack-map-table-attribute)) + "The attribute containing the stack map table, a map from bytecode offsets to frames containing information about the types of locals and values on the operand stack at that offset. This is an attribute of a method." + entries) + +(defun finalize-stack-map-table-attribute (table parent class) + "Prepares the `stack-map-table' attribute for serialization, within method `parent'." + (declare (ignore parent class)) ;;TODO + table) + +(defun write-stack-map-table-attribute (table stream) + (write-u2 (length (stack-map-table-entries table)) stream) + (dolist (frame (stack-map-table-entries table)) + (funcall (frame-writer frame) stream))) + +(defstruct (stack-map-frame (:conc-name frame-)) + offset-delta + writer) + +(defstruct (stack-map-full-frame + (:conc-name full-frame-) + (:include stack-map-frame + (writer #'write-stack-map-full-frame))) + locals + stack-items) + +(defun write-stack-map-full-frame (frame stream) + (write-u1 255 stream) + (write-u2 (frame-offset-delta frame) stream) + (write-u2 (length (full-frame-locals frame)) stream) + (dolist (local (full-frame-locals frame)) + (funcall (verification-type-info-writer local) local stream)) + (write-u2 (length (full-frame-stack-items frame)) stream) + (dolist (stack-item (full-frame-stack-items frame)) + (funcall (verification-type-info-writer stack-item) stack-item stream))) + +(defstruct verification-type-info tag (writer #'write-simple-verification-type-info)) + +(defstruct (top-variable-info (:include verification-type-info (tag 0)))) +(defstruct (integer-variable-info (:include verification-type-info (tag 1)))) +(defstruct (float-variable-info (:include verification-type-info (tag 2)))) +(defstruct (double-variable-info (:include verification-type-info (tag 3)))) +(defstruct (long-variable-info (:include verification-type-info (tag 4)))) +(defstruct (null-variable-info (:include verification-type-info (tag 5)))) +(defstruct (uninitialized-this-variable-info (:include verification-type-info (tag 6)))) +(defstruct (object-variable-info + (:include verification-type-info + (tag 7) (writer #'write-object-variable-info))) + constant-pool-index) +(defstruct (uninitialized-variable-info + (:include verification-type-info + (tag 8) (writer #'write-unitialized-variable-info))) + offset) + +(defun write-simple-verification-type-info (vti stream) + (write-u1 (verification-type-info-tag vti) stream)) +(defun write-object-variable-type-info (vti stream) + (write-u1 (verification-type-info-tag vti) stream) + (write-u2 (object-variable-info-constant-pool-index vti) stream)) +(defun write-uninitialized-verification-type-info (vti stream) + (write-u1 (verification-type-info-tag vti) stream) + (write-u2 (uninitialized-variable-info-offset vti) stream)) + +(defconst *opcode-effect-table* + (make-array 256 :initial-element #'(lambda (a b) (declare (ignore b)) a))) + +(defun opcode-effect-function (opcode) + (svref *opcode-effect-table* opcode)) + +(defvar *computed-stack* nil "The list of types on the stack calculated from the last emitted instruction, or from the method signature if no instruction has been emitted yet for the current method.") + +(defvar *computed-locals* nil "The list of types of local variables calculated from the last emitted instruction, or from the method signature if no instruction has been emitted yet for the current method.") + +(defmacro define-opcode-effect (opcode &body body) + `(setf (svref *opcode-effect-table* + (opcode-number ',opcode)) + #'(lambda (instruction) + (declare (ignorable instruction)) + , at body))) + +(defun update-stack-map-effect! (*computed-stack* *computed-locals* instruction) + (funcall (opcode-effect-function (instruction-opcode instruction)) + instruction) + (setf (instruction-stack-map-locals instruction) *computed-locals*) + (setf (instruction-stack-map-stack instruction) *computed-stack*) + instruction) + +(defun compute-stack-map-table (class method) + (let ((table (make-stack-map-table-attribute)) + (*computed-stack* (compute-initial-method-stack class method)) + (*computed-locals*)) + (finalize-stack-map-table table))) + +(defun finalize-stack-map-table (table) + "Replaces all virtual types in the stack map frames with variable-info objects." + ;;TODO + table) + +(defun compute-initial-method-stack (class method) + (let (locals) + (unless (member :static (method-access-flags method)) + (if (string= "" (method-name method)) + ;;the method is a constructor. + (push :uninitialized-this locals) + ;;the method is an instance method. + (push (class-name class) locals))) + (dolist (x (cdr (method-descriptor method))) + (push x locals)) + locals)) + +(defun smf-type->variable-info (type) + (case type)) + +(defun smf-push (type) + (push type *computed-stack*)) + +(defun smf-push2 (type) + (smf-push type) + (smf-push :top)) + +(defun smf-pop () + (pop *computed-stack*)) + +(defun smf-popn (n) + (dotimes (i n) + (pop *computed-stack*))) + +(defun smf-element-of (type) + (if (consp type) + (cdr type) + (error "Not an array stack map type: ~S" type))) + +(defun smf-array-of (type) + (cons :array-of type)) + +(define-opcode-effect aconst_null (smf-push :null)) +(define-opcode-effect iconst_m1 (smf-push :int)) +(define-opcode-effect iconst_0 (smf-push :int)) +(define-opcode-effect iconst_1 (smf-push :int)) +(define-opcode-effect iconst_2 (smf-push :int)) +(define-opcode-effect iconst_3 (smf-push :int)) +(define-opcode-effect iconst_4 (smf-push :int)) +(define-opcode-effect iconst_5 (smf-push :int)) +(define-opcode-effect lconst_0 (smf-push2 :long)) +(define-opcode-effect lconst_1 (smf-push2 :long)) +(define-opcode-effect fconst_0 (smf-push :float)) +(define-opcode-effect fconst_1 (smf-push :float)) +(define-opcode-effect fconst_2 (smf-push :float)) +(define-opcode-effect dconst_0 (smf-push2 :double)) +(define-opcode-effect dconst_1 (smf-push2 :double)) +(define-opcode-effect bipush (smf-push :int)) +(define-opcode-effect sipush (smf-push :int)) +(define-opcode-effect ldc + (case (constant-type (car (instruction-args instruction))) + (:int (smf-push :int)) + (:long (smf-push2 :long)) + (:float (smf-push :float)) + (:double (smf-push2 :double)) + (t (smf-push (car (instruction-args instruction)))))) +(define-opcode-effect iload (smf-push :int)) +(define-opcode-effect lload (smf-push2 :long)) +(define-opcode-effect fload (smf-push :float)) +(define-opcode-effect dload (smf-push2 :double)) +#|(define-opcode aload 25 2 1) ;;TODO +(define-opcode iload_0 26 1 1) +(define-opcode iload_1 27 1 1) +(define-opcode iload_2 28 1 1) +(define-opcode iload_3 29 1 1) +(define-opcode lload_0 30 1 2) +(define-opcode lload_1 31 1 2) +(define-opcode lload_2 32 1 2) +(define-opcode lload_3 33 1 2) +(define-opcode fload_0 34 1 nil) +(define-opcode fload_1 35 1 nil) +(define-opcode fload_2 36 1 nil) +(define-opcode fload_3 37 1 nil) +(define-opcode dload_0 38 1 nil) +(define-opcode dload_1 39 1 nil) +(define-opcode dload_2 40 1 nil) +(define-opcode dload_3 41 1 nil) +(define-opcode aload_0 42 1 1) +(define-opcode aload_1 43 1 1) +(define-opcode aload_2 44 1 1) +(define-opcode aload_3 45 1 1)|# +(define-opcode-effect iaload (smf-popn 2) (smf-push :int)) +(define-opcode-effect laload (smf-popn 2) (smf-push2 :long)) +(define-opcode-effect faload (smf-popn 2) (smf-push :float)) +(define-opcode-effect daload (smf-popn 2) (smf-push2 :double)) +#+nil ;;until there's newarray +(define-opcode-effect aaload + (progn + (smf-pop) + (smf-push (smf-element-of (smf-pop))))) +(define-opcode-effect baload (smf-popn 2) (smf-push :int)) +(define-opcode-effect caload (smf-popn 2) (smf-push :int)) +(define-opcode-effect saload (smf-popn 2) (smf-push :int)) +#|(define-opcode istore 54 2 -1) +(define-opcode lstore 55 2 -2) +(define-opcode fstore 56 2 nil) +(define-opcode dstore 57 2 nil) +(define-opcode astore 58 2 -1) +(define-opcode istore_0 59 1 -1) +(define-opcode istore_1 60 1 -1) +(define-opcode istore_2 61 1 -1) +(define-opcode istore_3 62 1 -1) +(define-opcode lstore_0 63 1 -2) +(define-opcode lstore_1 64 1 -2) +(define-opcode lstore_2 65 1 -2) +(define-opcode lstore_3 66 1 -2) +(define-opcode fstore_0 67 1 nil) +(define-opcode fstore_1 68 1 nil) +(define-opcode fstore_2 69 1 nil) +(define-opcode fstore_3 70 1 nil) +(define-opcode dstore_0 71 1 nil) +(define-opcode dstore_1 72 1 nil) +(define-opcode dstore_2 73 1 nil) +(define-opcode dstore_3 74 1 nil) +(define-opcode astore_0 75 1 -1) +(define-opcode astore_1 76 1 -1) +(define-opcode astore_2 77 1 -1) +(define-opcode astore_3 78 1 -1) +(define-opcode iastore 79 1 -3) +(define-opcode lastore 80 1 -4) +(define-opcode fastore 81 1 -3) +(define-opcode dastore 82 1 -4) +(define-opcode aastore 83 1 -3) +(define-opcode bastore 84 1 nil) +(define-opcode castore 85 1 nil) +(define-opcode sastore 86 1 nil) +(define-opcode pop 87 1 -1) +(define-opcode pop2 88 1 -2) +(define-opcode dup 89 1 1) +(define-opcode dup_x1 90 1 1) +(define-opcode dup_x2 91 1 1) +(define-opcode dup2 92 1 2) +(define-opcode dup2_x1 93 1 2) +(define-opcode dup2_x2 94 1 2) +(define-opcode swap 95 1 0) +(define-opcode iadd 96 1 -1) +(define-opcode ladd 97 1 -2) +(define-opcode fadd 98 1 -1) +(define-opcode dadd 99 1 -2) +(define-opcode isub 100 1 -1) +(define-opcode lsub 101 1 -2) +(define-opcode fsub 102 1 -1) +(define-opcode dsub 103 1 -2) +(define-opcode imul 104 1 -1) +(define-opcode lmul 105 1 -2) +(define-opcode fmul 106 1 -1) +(define-opcode dmul 107 1 -2) +(define-opcode idiv 108 1 nil) +(define-opcode ldiv 109 1 nil) +(define-opcode fdiv 110 1 nil) +(define-opcode ddiv 111 1 nil) +(define-opcode irem 112 1 nil) +(define-opcode lrem 113 1 nil) +(define-opcode frem 114 1 nil) +(define-opcode drem 115 1 nil) +(define-opcode ineg 116 1 0) +(define-opcode lneg 117 1 0) +(define-opcode fneg 118 1 0) +(define-opcode dneg 119 1 0) +(define-opcode ishl 120 1 -1) +(define-opcode lshl 121 1 -1) +(define-opcode ishr 122 1 -1) +(define-opcode lshr 123 1 -1) +(define-opcode iushr 124 1 nil) +(define-opcode lushr 125 1 nil) +(define-opcode iand 126 1 -1) +(define-opcode land 127 1 -2) +(define-opcode ior 128 1 -1) +(define-opcode lor 129 1 -2) +(define-opcode ixor 130 1 -1) +(define-opcode lxor 131 1 -2) +(define-opcode iinc 132 3 0) +(define-opcode i2l 133 1 1) +(define-opcode i2f 134 1 0) +(define-opcode i2d 135 1 1) +(define-opcode l2i 136 1 -1) +(define-opcode l2f 137 1 -1) +(define-opcode l2d 138 1 0) +(define-opcode f2i 139 1 nil) +(define-opcode f2l 140 1 nil) +(define-opcode f2d 141 1 1) +(define-opcode d2i 142 1 nil) +(define-opcode d2l 143 1 nil) +(define-opcode d2f 144 1 -1) +(define-opcode i2b 145 1 nil) +(define-opcode i2c 146 1 nil) +(define-opcode i2s 147 1 nil) +(define-opcode lcmp 148 1 -3) +(define-opcode fcmpl 149 1 -1) +(define-opcode fcmpg 150 1 -1) +(define-opcode dcmpl 151 1 -3) +(define-opcode dcmpg 152 1 -3) +(define-opcode ifeq 153 3 -1) +(define-opcode ifne 154 3 -1) +(define-opcode iflt 155 3 -1) +(define-opcode ifge 156 3 -1) +(define-opcode ifgt 157 3 -1) +(define-opcode ifle 158 3 -1) +(define-opcode if_icmpeq 159 3 -2) +(define-opcode if_icmpne 160 3 -2) +(define-opcode if_icmplt 161 3 -2) +(define-opcode if_icmpge 162 3 -2) +(define-opcode if_icmpgt 163 3 -2) +(define-opcode if_icmple 164 3 -2) +(define-opcode if_acmpeq 165 3 -2) +(define-opcode if_acmpne 166 3 -2) +(define-opcode goto 167 3 0) +;;(define-opcode jsr 168 3 1) Don't use these 2 opcodes: deprecated +;;(define-opcode ret 169 2 0) their use results in JVM verifier errors +(define-opcode tableswitch 170 0 nil) +(define-opcode lookupswitch 171 0 nil) +(define-opcode ireturn 172 1 nil) +(define-opcode lreturn 173 1 nil) +(define-opcode freturn 174 1 nil) +(define-opcode dreturn 175 1 nil) +(define-opcode areturn 176 1 -1) +(define-opcode return 177 1 0) +(define-opcode getstatic 178 3 1) +(define-opcode putstatic 179 3 -1) +(define-opcode getfield 180 3 0) +(define-opcode putfield 181 3 -2) +(define-opcode invokevirtual 182 3 nil) +(define-opcode invokespecial 183 3 nil) +(define-opcode invokestatic 184 3 nil) +(define-opcode invokeinterface 185 5 nil) +(define-opcode unused 186 0 nil) +(define-opcode new 187 3 1) +(define-opcode newarray 188 2 nil) +(define-opcode anewarray 189 3 0) +(define-opcode arraylength 190 1 0) +(define-opcode athrow 191 1 0) +(define-opcode checkcast 192 3 0) +(define-opcode instanceof 193 3 0) +(define-opcode monitorenter 194 1 -1) +(define-opcode monitorexit 195 1 -1) +(define-opcode wide 196 0 nil) +(define-opcode multianewarray 197 4 nil) +(define-opcode ifnull 198 3 -1) +(define-opcode ifnonnull 199 3 nil) +(define-opcode goto_w 200 5 nil) +;; (define-opcode jsr_w 201 5 nil) Don't use: deprecated +(define-opcode label 202 0 0) ;; virtual: does not exist in the JVM +;; (define-opcode push-value 203 nil 1) +;; (define-opcode store-value 204 nil -1) +(define-opcode clear-values 205 0 0) ;; virtual: does not exist in the JVM +;;(define-opcode var-ref 206 0 0)|# + #| ;; this is the minimal sequence we need to support: Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp ============================================================================== --- branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp (original) +++ branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Wed Oct 6 18:03:56 2010 @@ -449,8 +449,9 @@ (list (inst 'aload (car (instruction-args instruction))) (inst 'aconst_null) - (inst 'putfield (u2 (pool-field +lisp-thread+ "_values" - +lisp-object-array+))))) + (inst 'putfield (u2 (constant-index + (pool-field +lisp-thread+ "_values" + +lisp-object-array+)))))) (vector-push-extend instruction vector))) (t (vector-push-extend instruction vector))))))) @@ -654,16 +655,17 @@ (let* ((args (instruction-args instruction))) (unless (= (length args) 1) (error "Wrong number of args for LDC.")) - (if (> (car args) 255) - (inst 19 (u2 (car args))) ; LDC_W - (inst 18 args)))) + (let ((index (constant-index (car args)))) + (if (> index 255) + (inst 19 (u2 index)) ; LDC_W + (inst 18 args))))) ;; ldc2_w (define-resolver 20 (instruction) (let* ((args (instruction-args instruction))) (unless (= (length args) 1) (error "Wrong number of args for LDC2_W.")) - (inst 20 (u2 (car args))))) + (inst 20 (u2 (constant-index (car args)))))) ;; iinc (define-resolver 132 (instruction) @@ -984,8 +986,9 @@ (unless (= (instruction-opcode instruction) 202) ; LABEL (setf (svref bytes index) (instruction-opcode instruction)) (incf index) - (dolist (byte (instruction-args instruction)) - (setf (svref bytes index) byte) + (dolist (arg (instruction-args instruction)) + (setf (svref bytes index) + (if (constant-p arg) (constant-index arg) arg)) (incf index))))) (values bytes labels)))) From ehuelsmann at common-lisp.net Thu Oct 7 22:35:52 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 07 Oct 2010 18:35:52 -0400 Subject: [armedbear-cvs] r12954 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Oct 7 18:35:50 2010 New Revision: 12954 Log: Replace unsynchronized data types with concurrency-supporting synchronized data types from the java.util.concurrent package in CLOS supporting code. Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Thu Oct 7 18:35:50 2010 @@ -35,7 +35,7 @@ import static org.armedbear.lisp.Lisp.*; -import java.util.HashMap; +import java.util.concurrent.ConcurrentHashMap; public final class StandardGenericFunction extends StandardObject { @@ -43,8 +43,8 @@ int numberOfRequiredArgs; - HashMap cache; - HashMap slotCache; + ConcurrentHashMap cache; + ConcurrentHashMap slotCache; public StandardGenericFunction() { @@ -581,9 +581,9 @@ args = args.cdr(); } CacheEntry specializations = new CacheEntry(array); - HashMap ht = gf.cache; + ConcurrentHashMap ht = gf.cache; if (ht == null) - ht = gf.cache = new HashMap(); + ht = gf.cache = new ConcurrentHashMap(); ht.put(specializations, third); return third; } @@ -606,7 +606,7 @@ args = args.cdr(); } CacheEntry specializations = new CacheEntry(array); - HashMap ht = gf.cache; + ConcurrentHashMap ht = gf.cache; if (ht == null) return NIL; LispObject emf = (LispObject) ht.get(specializations); @@ -705,9 +705,9 @@ final StandardGenericFunction gf = checkStandardGenericFunction(first); LispObject layout = second; LispObject location = third; - HashMap ht = gf.slotCache; + ConcurrentHashMap ht = gf.slotCache; if (ht == null) - ht = gf.slotCache = new HashMap(); + ht = gf.slotCache = new ConcurrentHashMap(); ht.put(layout, location); return third; } @@ -723,7 +723,7 @@ { final StandardGenericFunction gf = checkStandardGenericFunction(first); LispObject layout = second; - HashMap ht = gf.slotCache; + ConcurrentHashMap ht = gf.slotCache; if (ht == null) return NIL; LispObject location = (LispObject) ht.get(layout); From ehuelsmann at common-lisp.net Thu Oct 7 22:37:19 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 07 Oct 2010 18:37:19 -0400 Subject: [armedbear-cvs] r12955 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Oct 7 18:37:17 2010 New Revision: 12955 Log: In CLOS supporting code (Layout.java), replace a synchronized hash table type by a ConcurrentHashMap for non-blocking readers. Modified: trunk/abcl/src/org/armedbear/lisp/Layout.java Modified: trunk/abcl/src/org/armedbear/lisp/Layout.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Layout.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Layout.java Thu Oct 7 18:37:17 2010 @@ -33,12 +33,13 @@ package org.armedbear.lisp; +import java.util.concurrent.ConcurrentHashMap; import static org.armedbear.lisp.Lisp.*; public class Layout extends LispObject { private final LispObject lispClass; - public final EqHashTable slotTable; + public final ConcurrentHashMap slotTable; final LispObject[] slotNames; final LispObject sharedSlots; @@ -82,9 +83,9 @@ slotTable = initializeSlotTable(slotNames); } - private EqHashTable initializeSlotTable(LispObject[] slotNames) + private ConcurrentHashMap initializeSlotTable(LispObject[] slotNames) { - EqHashTable ht = new EqHashTable(slotNames.length, NIL, NIL); + ConcurrentHashMap ht = new ConcurrentHashMap(slotNames.length); for (int i = slotNames.length; i-- > 0;) ht.put(slotNames[i], Fixnum.getInstance(i)); return ht; From ehuelsmann at common-lisp.net Fri Oct 8 18:03:16 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 08 Oct 2010 14:03:16 -0400 Subject: [armedbear-cvs] r12956 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Oct 8 14:03:13 2010 New Revision: 12956 Log: Make FIND-CLASS use a class which supports non-blocking reading from a hash: ConcurrentHashMap. Modified: trunk/abcl/src/org/armedbear/lisp/LispClass.java Modified: trunk/abcl/src/org/armedbear/lisp/LispClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispClass.java Fri Oct 8 14:03:13 2010 @@ -33,44 +33,34 @@ package org.armedbear.lisp; +import java.util.concurrent.ConcurrentHashMap; import static org.armedbear.lisp.Lisp.*; public abstract class LispClass extends StandardObject { - private static final EqHashTable map = new EqHashTable(256, NIL, NIL); + private static final ConcurrentHashMap map + = new ConcurrentHashMap(); public static LispClass addClass(Symbol symbol, LispClass c) { - synchronized (map) - { - map.put(symbol, c); - } + map.put(symbol, c); return c; } public static LispObject addClass(Symbol symbol, LispObject c) { - synchronized (map) - { - map.put(symbol, c); - } + map.put(symbol, c); return c; } public static void removeClass(Symbol symbol) { - synchronized (map) - { - map.remove(symbol); - } + map.remove(symbol); } public static LispClass findClass(Symbol symbol) { - synchronized (map) - { - return (LispClass) map.get(symbol); - } + return (LispClass)map.get(symbol); } public static LispObject findClass(LispObject name, boolean errorp) @@ -78,10 +68,7 @@ { final Symbol symbol = checkSymbol(name); final LispObject c; - synchronized (map) - { - c = map.get(symbol); - } + c = map.get(symbol); if (c != null) return c; if (errorp) From ehuelsmann at common-lisp.net Fri Oct 8 18:43:36 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 08 Oct 2010 14:43:36 -0400 Subject: [armedbear-cvs] r12957 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Oct 8 14:43:36 2010 New Revision: 12957 Log: Use a synchronized hash table with weak keys to allow garbage collection of the symbols in it - and of the function_info with the symbols as soon as they disappear. Modified: trunk/abcl/src/org/armedbear/lisp/function_info.java Modified: trunk/abcl/src/org/armedbear/lisp/function_info.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/function_info.java (original) +++ trunk/abcl/src/org/armedbear/lisp/function_info.java Fri Oct 8 14:43:36 2010 @@ -33,12 +33,16 @@ package org.armedbear.lisp; +import java.util.Map; +import java.util.Collections; +import java.util.WeakHashMap; import static org.armedbear.lisp.Lisp.*; public final class function_info { - static EqualHashTable FUNCTION_TABLE = - new EqualHashTable(64, NIL, NIL); + // ### TODO: Replace by a concurrent hashmap, with weak keys, ofcourse. + final static Map symbolToFunctionMap = + Collections.synchronizedMap(new WeakHashMap()); // ### function-info name private static final Primitive FUNCTION_INFO = @@ -47,7 +51,7 @@ @Override public LispObject execute(LispObject arg) { - LispObject info = FUNCTION_TABLE.get(arg); + LispObject info = symbolToFunctionMap.get(arg); return info != null ? info : NIL; } }; @@ -61,9 +65,9 @@ { if (info == NIL) - FUNCTION_TABLE.remhash(name); + symbolToFunctionMap.remove(name); else - FUNCTION_TABLE.put(name, info); + symbolToFunctionMap.put(name, info); return info; } }; @@ -78,7 +82,7 @@ { // info is an alist - LispObject info = FUNCTION_TABLE.get(name); + LispObject info = symbolToFunctionMap.get(name); if (info != null) { while (info != NIL) { LispObject cons = info.car(); @@ -107,7 +111,7 @@ { // info is an alist - LispObject info = FUNCTION_TABLE.get(name); + LispObject info = symbolToFunctionMap.get(name); if (info == null) info = NIL; LispObject alist = info; @@ -124,7 +128,7 @@ alist = alist.cdr(); } // Not found. - FUNCTION_TABLE.put(name, info.push(new Cons(indicator, value))); + symbolToFunctionMap.put(name, info.push(new Cons(indicator, value))); return value; } }; From ehuelsmann at common-lisp.net Fri Oct 8 22:05:38 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 08 Oct 2010 18:05:38 -0400 Subject: [armedbear-cvs] r12958 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Oct 8 18:05:37 2010 New Revision: 12958 Log: Implement SimpleString.toString() using String.valueOf(). Modified: trunk/abcl/src/org/armedbear/lisp/SimpleString.java Modified: trunk/abcl/src/org/armedbear/lisp/SimpleString.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SimpleString.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SimpleString.java Fri Oct 8 18:05:37 2010 @@ -487,4 +487,9 @@ { return new ComplexString(newCapacity, displacedTo, displacement); } + + @Override + public String toString() { + return String.valueOf(chars); + } } From ehuelsmann at common-lisp.net Fri Oct 8 22:08:44 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 08 Oct 2010 18:08:44 -0400 Subject: [armedbear-cvs] r12959 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Oct 8 18:08:43 2010 New Revision: 12959 Log: Remove as much synchronization as possible from package symbols tables, in order to prevent synchronization to kick in on each FIND-SYMBOL call. Modified: trunk/abcl/src/org/armedbear/lisp/Package.java Modified: trunk/abcl/src/org/armedbear/lisp/Package.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Package.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Package.java Fri Oct 8 18:08:43 2010 @@ -36,9 +36,11 @@ import static org.armedbear.lisp.Lisp.*; import java.util.ArrayList; +import java.util.Collection; import java.util.HashMap; import java.util.Iterator; import java.util.List; +import java.util.concurrent.ConcurrentHashMap; public final class Package extends LispObject implements java.io.Serializable { @@ -47,8 +49,10 @@ private transient LispObject propertyList; - private transient final SymbolHashTable internalSymbols = new SymbolHashTable(16); - private transient final SymbolHashTable externalSymbols = new SymbolHashTable(16); + private transient final ConcurrentHashMap internalSymbols + = new ConcurrentHashMap(16); + private transient final ConcurrentHashMap externalSymbols + = new ConcurrentHashMap(16); private transient HashMap shadowingSymbols; private transient ArrayList nicknames; @@ -141,23 +145,13 @@ { if (name != null) { Packages.deletePackage(this); - List internals = internalSymbols.getSymbols(); - for (int i = internals.size(); i-- > 0;) { - Symbol symbol = (Symbol) internals.get(i); - if (symbol.getPackage() == this) - symbol.setPackage(NIL); - internalSymbols.remove(symbol); - } - List externals = externalSymbols.getSymbols(); - for (int i = externals.size(); i-- > 0;) { - Symbol symbol = (Symbol) externals.get(i); - if (symbol.getPackage() == this) - symbol.setPackage(NIL); - externalSymbols.remove(symbol); - } + internalSymbols.clear(); + externalSymbols.clear(); + name = null; lispName = null; nicknames = null; + return true; } return false; @@ -183,37 +177,37 @@ Packages.addPackage(this); } - public synchronized Symbol findInternalSymbol(SimpleString name) + public Symbol findInternalSymbol(SimpleString name) { - return internalSymbols.get(name); + return internalSymbols.get(name.toString()); } - public synchronized Symbol findExternalSymbol(SimpleString name) + public Symbol findExternalSymbol(SimpleString name) { - return externalSymbols.get(name); + return externalSymbols.get(name.toString()); } - public synchronized Symbol findExternalSymbol(SimpleString name, int hash) + public Symbol findExternalSymbol(SimpleString name, int hash) { - return externalSymbols.get(name, hash); + return externalSymbols.get(name.toString()); } // Returns null if symbol is not accessible in this package. - public synchronized Symbol findAccessibleSymbol(String name) + public Symbol findAccessibleSymbol(String name) { return findAccessibleSymbol(new SimpleString(name)); } // Returns null if symbol is not accessible in this package. - public synchronized Symbol findAccessibleSymbol(SimpleString name) + public Symbol findAccessibleSymbol(SimpleString name) { // Look in external and internal symbols of this package. - Symbol symbol = externalSymbols.get(name); + Symbol symbol = externalSymbols.get(name.toString()); if (symbol != null) return symbol; - symbol = internalSymbols.get(name); + symbol = internalSymbols.get(name.toString()); if (symbol != null) return symbol; // Look in external symbols of used packages. @@ -231,16 +225,16 @@ return null; } - public synchronized LispObject findSymbol(String name) + public LispObject findSymbol(String name) { final SimpleString s = new SimpleString(name); final LispThread thread = LispThread.currentThread(); // Look in external and internal symbols of this package. - Symbol symbol = externalSymbols.get(s); + Symbol symbol = externalSymbols.get(name); if (symbol != null) return thread.setValues(symbol, Keyword.EXTERNAL); - symbol = internalSymbols.get(s); + symbol = internalSymbols.get(name); if (symbol != null) return thread.setValues(symbol, Keyword.INTERNAL); // Look in external symbols of used packages. @@ -259,52 +253,56 @@ } // Helper function to add NIL to PACKAGE_CL. - public synchronized void addSymbol(Symbol symbol) + public void addSymbol(Symbol symbol) { Debug.assertTrue(symbol.getPackage() == this); Debug.assertTrue(symbol.getName().equals("NIL")); - externalSymbols.put(symbol.name, symbol); + externalSymbols.put(symbol.name.toString(), symbol); } - private synchronized Symbol addSymbol(SimpleString name, int hash) + private Symbol addSymbol(String name) { - Symbol symbol = new Symbol(name, hash, this); + Symbol symbol = new Symbol(name, this); if (this == PACKAGE_KEYWORD) { symbol.initializeConstant(symbol); - externalSymbols.put(name, symbol); + externalSymbols.put(name.toString(), symbol); } else - internalSymbols.put(name, symbol); + internalSymbols.put(name.toString(), symbol); return symbol; } - public synchronized Symbol addInternalSymbol(String symbolName) + private Symbol addSymbol(SimpleString name) + { + return addSymbol(name.toString()); + } + + public Symbol addInternalSymbol(String symbolName) { final Symbol symbol = new Symbol(symbolName, this); - internalSymbols.put(symbol); + internalSymbols.put(symbolName, symbol); return symbol; } - public synchronized Symbol addExternalSymbol(String symbolName) + public Symbol addExternalSymbol(String symbolName) { final Symbol symbol = new Symbol(symbolName, this); - externalSymbols.put(symbol); + externalSymbols.put(symbolName, symbol); return symbol; } - public synchronized Symbol intern(String symbolName) + public synchronized Symbol intern(SimpleString symbolName) { - return intern(new SimpleString(symbolName)); + return intern(symbolName.toString()); } - public synchronized Symbol intern(SimpleString symbolName) + public synchronized Symbol intern(String symbolName) { - final int hash = symbolName.sxhash(); // Look in external and internal symbols of this package. - Symbol symbol = externalSymbols.get(symbolName, hash); + Symbol symbol = externalSymbols.get(symbolName); if (symbol != null) return symbol; - symbol = internalSymbols.get(symbolName, hash); + symbol = internalSymbols.get(symbolName); if (symbol != null) return symbol; // Look in external symbols of used packages. @@ -312,25 +310,24 @@ LispObject usedPackages = useList; while (usedPackages != NIL) { Package pkg = (Package) usedPackages.car(); - symbol = pkg.findExternalSymbol(symbolName, hash); + symbol = pkg.externalSymbols.get(symbolName); if (symbol != null) return symbol; usedPackages = usedPackages.cdr(); } } // Not found. - return addSymbol(symbolName, hash); + return addSymbol(symbolName); } public synchronized Symbol intern(final SimpleString s, final LispThread thread) { - final int hash = s.sxhash(); // Look in external and internal symbols of this package. - Symbol symbol = externalSymbols.get(s, hash); + Symbol symbol = externalSymbols.get(s.toString()); if (symbol != null) return (Symbol) thread.setValues(symbol, Keyword.EXTERNAL); - symbol = internalSymbols.get(s, hash); + symbol = internalSymbols.get(s.toString()); if (symbol != null) return (Symbol) thread.setValues(symbol, Keyword.INTERNAL); // Look in external symbols of used packages. @@ -338,26 +335,25 @@ LispObject usedPackages = useList; while (usedPackages != NIL) { Package pkg = (Package) usedPackages.car(); - symbol = pkg.findExternalSymbol(s, hash); + symbol = pkg.findExternalSymbol(s); if (symbol != null) return (Symbol) thread.setValues(symbol, Keyword.INHERITED); usedPackages = usedPackages.cdr(); } } // Not found. - return (Symbol) thread.setValues(addSymbol(s, hash), NIL); + return (Symbol) thread.setValues(addSymbol(s), NIL); } public synchronized Symbol internAndExport(String symbolName) { final SimpleString s = new SimpleString(symbolName); - final int hash = s.sxhash(); // Look in external and internal symbols of this package. - Symbol symbol = externalSymbols.get(s, hash); + Symbol symbol = externalSymbols.get(s.toString()); if (symbol != null) return symbol; - symbol = internalSymbols.get(s, hash); + symbol = internalSymbols.get(s.toString()); if (symbol != null) { export(symbol); return symbol; @@ -367,7 +363,7 @@ LispObject usedPackages = useList; while (usedPackages != NIL) { Package pkg = (Package) usedPackages.car(); - symbol = pkg.findExternalSymbol(s, hash); + symbol = pkg.findExternalSymbol(s); if (symbol != null) { export(symbol); return symbol; @@ -376,10 +372,10 @@ } } // Not found. - symbol = new Symbol(s, hash, this); + symbol = new Symbol(s, this); if (this == PACKAGE_KEYWORD) symbol.initializeConstant(symbol); - externalSymbols.put(s, symbol); + externalSymbols.put(s.toString(), symbol); return symbol; } @@ -420,10 +416,10 @@ } } // Reaching here, it's OK to remove the symbol. - if (internalSymbols.get(symbol.name) == symbol) - internalSymbols.remove(symbol.name); - else if (externalSymbols.get(symbol.name) == symbol) - externalSymbols.remove(symbol.name); + if (internalSymbols.get(symbol.name.toString()) == symbol) + internalSymbols.remove(symbol.name.toString()); + else if (externalSymbols.get(symbol.name.toString()) == symbol) + externalSymbols.remove(symbol.name.toString()); else // Not found. return NIL; @@ -449,7 +445,7 @@ sb.append('.'); error(new PackageError(sb.toString())); } - internalSymbols.put(symbol.name, symbol); + internalSymbols.put(symbol.name.toString(), symbol); if (symbol.getPackage() == NIL) symbol.setPackage(this); } @@ -469,10 +465,10 @@ error(new PackageError(sb.toString())); return; } - internalSymbols.put(symbol.name, symbol); + internalSymbols.put(symbol.name.toString(), symbol); added = true; } - if (added || internalSymbols.get(symbol.name) == symbol) { + if (added || internalSymbols.get(symbol.name.toString()) == symbol) { if (usedByList != null) { for (Iterator it = usedByList.iterator(); it.hasNext();) { Package pkg = (Package) it.next(); @@ -494,11 +490,11 @@ } } // No conflicts. - internalSymbols.remove(symbol.name); - externalSymbols.put(symbol.name, symbol); + internalSymbols.remove(symbol.name.toString()); + externalSymbols.put(symbol.name.toString(), symbol); return; } - if (externalSymbols.get(symbol.name) == symbol) + if (externalSymbols.get(symbol.name.toString()) == symbol) // Symbol is already exported; there's nothing to do. return; StringBuilder sb = new StringBuilder("The symbol "); @@ -513,9 +509,9 @@ { if (symbol.getPackage() == this) { - if (externalSymbols.get(symbol.name) == symbol) { - externalSymbols.remove(symbol.name); - internalSymbols.put(symbol.name, symbol); + if (externalSymbols.get(symbol.name.toString()) == symbol) { + externalSymbols.remove(symbol.name.toString()); + internalSymbols.put(symbol.name.toString(), symbol); } } else { // Signal an error if symbol is not accessible. @@ -542,12 +538,12 @@ if (shadowingSymbols == null) shadowingSymbols = new HashMap(); final SimpleString s = new SimpleString(symbolName); - Symbol symbol = externalSymbols.get(s); + Symbol symbol = externalSymbols.get(s.toString()); if (symbol != null) { shadowingSymbols.put(symbolName, symbol); return; } - symbol = internalSymbols.get(s); + symbol = internalSymbols.get(s.toString()); if (symbol != null) { shadowingSymbols.put(symbolName, symbol); return; @@ -555,7 +551,7 @@ if (shadowingSymbols.get(symbolName) != null) return; symbol = new Symbol(s, this); - internalSymbols.put(s, symbol); + internalSymbols.put(s.toString(), symbol); shadowingSymbols.put(symbolName, symbol); } @@ -563,11 +559,11 @@ { LispObject where = NIL; final String symbolName = symbol.getName(); - Symbol sym = externalSymbols.get(symbol.name); + Symbol sym = externalSymbols.get(symbol.name.toString()); if (sym != null) { where = Keyword.EXTERNAL; } else { - sym = internalSymbols.get(symbol.name); + sym = internalSymbols.get(symbol.name.toString()); if (sym != null) { where = Keyword.INTERNAL; } else { @@ -600,7 +596,7 @@ } } } - internalSymbols.put(symbol.name, symbol); + internalSymbols.put(symbol.name.toString(), symbol); if (shadowingSymbols == null) shadowingSymbols = new HashMap(); Debug.assertTrue(shadowingSymbols.get(symbolName) == null); @@ -617,9 +613,9 @@ if (!memq(pkg, useList)) { // "USE-PACKAGE checks for name conflicts between the newly // imported symbols and those already accessible in package." - List symbols = pkg.getExternalSymbols(); - for (int i = symbols.size(); i-- > 0;) { - Symbol symbol = (Symbol) symbols.get(i); + Collection symbols = pkg.getExternalSymbols(); + for (Iterator i = symbols.iterator(); i.hasNext();) { + Symbol symbol = i.next(); Symbol existing = findAccessibleSymbol(symbol.name); if (existing != null && existing != symbol) { if (shadowingSymbols == null || @@ -731,26 +727,22 @@ return list; } - public synchronized List getExternalSymbols() + public synchronized Collection getExternalSymbols() { - return externalSymbols.getSymbols(); + return externalSymbols.values(); } public synchronized List getAccessibleSymbols() { ArrayList list = new ArrayList(); - list.addAll(internalSymbols.getSymbols()); - list.addAll(externalSymbols.getSymbols()); + list.addAll(internalSymbols.values()); + list.addAll(externalSymbols.values()); if (useList instanceof Cons) { LispObject usedPackages = useList; while (usedPackages != NIL) { Package pkg = (Package) usedPackages.car(); - List symbols = pkg.externalSymbols.getSymbols(); - for (int i = 0; i < symbols.size(); i++) { - Symbol symbol = (Symbol) symbols.get(i); - if (shadowingSymbols == null || shadowingSymbols.get(symbol.getName()) == null) - list.add(symbol); - } + list.addAll(pkg.externalSymbols.values()); + usedPackages = usedPackages.cdr(); } } @@ -760,18 +752,18 @@ public synchronized LispObject PACKAGE_INTERNAL_SYMBOLS() { LispObject list = NIL; - List symbols = internalSymbols.getSymbols(); - for (int i = symbols.size(); i-- > 0;) - list = new Cons((Symbol)symbols.get(i), list); + Collection symbols = internalSymbols.values(); + for (Iterator i = symbols.iterator(); i.hasNext();) + list = new Cons(i.next(), list); return list; } public synchronized LispObject PACKAGE_EXTERNAL_SYMBOLS() { LispObject list = NIL; - List symbols = externalSymbols.getSymbols(); - for (int i = symbols.size(); i-- > 0;) - list = new Cons((Symbol)symbols.get(i), list); + Collection symbols = externalSymbols.values(); + for (Iterator i = symbols.iterator(); i.hasNext();) + list = new Cons(i.next(), list); return list; } @@ -782,12 +774,12 @@ LispObject usedPackages = useList; while (usedPackages != NIL) { Package pkg = (Package) usedPackages.car(); - List externals = pkg.getExternalSymbols(); - for (int i = externals.size(); i-- > 0;) { - Symbol symbol = (Symbol) externals.get(i); + Collection externals = pkg.getExternalSymbols(); + for (Iterator i = externals.iterator(); i.hasNext();) { + Symbol symbol = i.next(); if (shadowingSymbols != null && shadowingSymbols.get(symbol.getName()) != null) continue; - if (externalSymbols.get(symbol.name) == symbol) + if (externalSymbols.get(symbol.name.toString()) == symbol) continue; list = new Cons(symbol, list); } @@ -800,19 +792,19 @@ public synchronized LispObject getSymbols() { LispObject list = NIL; - List internals = internalSymbols.getSymbols(); - for (int i = internals.size(); i-- > 0;) - list = new Cons((Symbol)internals.get(i), list); - List externals = externalSymbols.getSymbols(); - for (int i = externals.size(); i-- > 0;) - list = new Cons((Symbol)externals.get(i), list); + Collection internals = internalSymbols.values(); + for (Iterator i = internals.iterator(); i.hasNext();) + list = new Cons(i.next(), list); + Collection externals = externalSymbols.values(); + for (Iterator i = externals.iterator(); i.hasNext();) + list = new Cons(i.next(), list); return list; } public synchronized Symbol[] symbols() { - List internals = internalSymbols.getSymbols(); - List externals = externalSymbols.getSymbols(); + Collection internals = internalSymbols.values(); + Collection externals = externalSymbols.values(); Symbol[] array = new Symbol[internals.size() + externals.size()]; int i = 0; for (Iterator it = internals.iterator(); it.hasNext();) { From ehuelsmann at common-lisp.net Fri Oct 8 22:11:08 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 08 Oct 2010 18:11:08 -0400 Subject: [armedbear-cvs] r12960 - trunk/abcl Message-ID: Author: ehuelsmann Date: Fri Oct 8 18:11:07 2010 New Revision: 12960 Log: Add Ant target which allows JPDA/IDE-based debugging of ABCL's startup/initialization and self-building phase. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Fri Oct 8 18:11:07 2010 @@ -424,6 +424,18 @@ JPDA listening on localhost:6789 + + Invoke ABCL with JPDA listener on port 6789 + + + + + JPDA listening on localhost:6789 + + Author: ehuelsmann Date: Sat Oct 9 09:27:10 2010 New Revision: 12961 Log: Remove SymbolHashTable, which isn't used anymore, now that Package uses ConcurrentHashTable directly. Removed: trunk/abcl/src/org/armedbear/lisp/SymbolHashTable.java From ehuelsmann at common-lisp.net Sat Oct 9 19:28:29 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 09 Oct 2010 15:28:29 -0400 Subject: [armedbear-cvs] r12962 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 9 15:28:27 2010 New Revision: 12962 Log: Remove unused constructors. Modified: trunk/abcl/src/org/armedbear/lisp/HashTable.java Modified: trunk/abcl/src/org/armedbear/lisp/HashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/HashTable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/HashTable.java Sat Oct 9 15:28:27 2010 @@ -54,14 +54,6 @@ // The number of key-value pairs. protected int count; - protected HashTable() - { - rehashSize = new SingleFloat(1.5f); // FIXME - rehashThreshold = new SingleFloat(0.75f); // FIXME - buckets = new HashEntry[DEFAULT_SIZE]; - threshold = (int) (DEFAULT_SIZE * loadFactor); - } - protected HashTable(int size, LispObject rehashSize, LispObject rehashThreshold) { From ehuelsmann at common-lisp.net Sat Oct 9 19:28:44 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 09 Oct 2010 15:28:44 -0400 Subject: [armedbear-cvs] r12963 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 9 15:28:43 2010 New Revision: 12963 Log: Remove unused constructors. Modified: trunk/abcl/src/org/armedbear/lisp/EqlHashTable.java Modified: trunk/abcl/src/org/armedbear/lisp/EqlHashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/EqlHashTable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/EqlHashTable.java Sat Oct 9 15:28:43 2010 @@ -37,10 +37,6 @@ { private int mask; - public EqlHashTable() - { - } - public EqlHashTable(int size, LispObject rehashSize, LispObject rehashThreshold) { From ehuelsmann at common-lisp.net Sat Oct 9 20:40:54 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 09 Oct 2010 16:40:54 -0400 Subject: [armedbear-cvs] r12964 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 9 16:40:53 2010 New Revision: 12964 Log: Don't inline constructors, from where I stand - and without reference to why they were introduced - these can't make a measurable impact on our performance. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Oct 9 16:40:53 2010 @@ -4561,113 +4561,6 @@ (fix-boxing representation nil) (emit-move-from-stack target representation)))) -(defun p2-make-array (form target representation) - ;; In safe code, we want to make sure the requested length does not exceed - ;; ARRAY-DIMENSION-LIMIT. - (cond ((and (< *safety* 3) - (= (length form) 2) - (fixnum-type-p (derive-compiler-type (second form))) - (null representation)) - (let ((arg (second form))) - (emit-new +lisp-simple-vector+) - (emit 'dup) - (compile-forms-and-maybe-emit-clear-values arg 'stack :int) - (emit-invokespecial-init +lisp-simple-vector+ '(:int)) - (emit-move-from-stack target representation))) - (t - (compile-function-call form target representation)))) - -;; make-sequence result-type size &key initial-element => sequence -(define-inlined-function p2-make-sequence (form target representation) - ;; In safe code, we want to make sure the requested length does not exceed - ;; ARRAY-DIMENSION-LIMIT. - ((and (< *safety* 3) - (= (length form) 3) - (null representation))) - (let* ((args (cdr form)) - (arg1 (first args)) - (arg2 (second args))) - (when (and (consp arg1) - (= (length arg1) 2) - (eq (first arg1) 'QUOTE)) - (let* ((result-type (second arg1)) - (class - (case result-type - ((STRING SIMPLE-STRING) - (setf class +lisp-simple-string+)) - ((VECTOR SIMPLE-VECTOR) - (setf class +lisp-simple-vector+))))) - (when class - (emit-new class) - (emit 'dup) - (compile-forms-and-maybe-emit-clear-values arg2 'stack :int) - (emit-invokespecial-init class '(:int)) - (emit-move-from-stack target representation) - (return-from p2-make-sequence))))) - (compile-function-call form target representation)) - -(defun p2-make-string (form target representation) - ;; In safe code, we want to make sure the requested length does not exceed - ;; ARRAY-DIMENSION-LIMIT. - (cond ((and (< *safety* 3) - (= (length form) 2) - (null representation)) - (let ((arg (second form))) - (emit-new +lisp-simple-string+) - (emit 'dup) - (compile-forms-and-maybe-emit-clear-values arg 'stack :int) - (emit-invokespecial-init +lisp-simple-string+ '(:int)) - (emit-move-from-stack target representation))) - (t - (compile-function-call form target representation)))) - -(defun p2-%make-structure (form target representation) - (cond ((and (check-arg-count form 2) - (eq (derive-type (%cadr form)) 'SYMBOL)) - (emit-new +lisp-structure-object+) - (emit 'dup) - (compile-form (%cadr form) 'stack nil) - (emit-checkcast +lisp-symbol+) - (compile-form (%caddr form) 'stack nil) - (maybe-emit-clear-values (%cadr form) (%caddr form)) - (emit-invokevirtual +lisp-object+ "copyToArray" - nil +lisp-object-array+) - (emit-invokespecial-init +lisp-structure-object+ - (list +lisp-symbol+ +lisp-object-array+)) - (emit-move-from-stack target representation)) - (t - (compile-function-call form target representation)))) - -(defun p2-make-structure (form target representation) - (let* ((args (cdr form)) - (slot-forms (cdr args)) - (slot-count (length slot-forms))) - (cond ((and (<= 1 slot-count 6) - (eq (derive-type (%car args)) 'SYMBOL)) - (emit-new +lisp-structure-object+) - (emit 'dup) - (compile-form (%car args) 'stack nil) - (emit-checkcast +lisp-symbol+) - (dolist (slot-form slot-forms) - (compile-form slot-form 'stack nil)) - (apply 'maybe-emit-clear-values args) - (emit-invokespecial-init +lisp-structure-object+ - (append (list +lisp-symbol+) - (make-list slot-count :initial-element +lisp-object+))) - (emit-move-from-stack target representation)) - (t - (compile-function-call form target representation))))) - -(defun p2-make-hash-table (form target representation) - (cond ((= (length form) 1) ; no args - (emit-new +lisp-eql-hash-table+) - (emit 'dup) - (emit-invokespecial-init +lisp-eql-hash-table+ nil) - (fix-boxing representation nil) - (emit-move-from-stack target representation)) - (t - (compile-function-call form target representation)))) - (defknown p2-stream-element-type (t t t) t) (define-inlined-function p2-stream-element-type (form target representation) ((check-arg-count form 1)) @@ -7342,7 +7235,6 @@ nth progn)) (install-p2-handler '%ldb 'p2-%ldb) - (install-p2-handler '%make-structure 'p2-%make-structure) (install-p2-handler '* 'p2-times) (install-p2-handler '+ 'p2-plus) (install-p2-handler '- 'p2-minus) @@ -7397,11 +7289,6 @@ (install-p2-handler 'logior 'p2-logior) (install-p2-handler 'lognot 'p2-lognot) (install-p2-handler 'logxor 'p2-logxor) - (install-p2-handler 'make-array 'p2-make-array) - (install-p2-handler 'make-hash-table 'p2-make-hash-table) - (install-p2-handler 'make-sequence 'p2-make-sequence) - (install-p2-handler 'make-string 'p2-make-string) - (install-p2-handler 'make-structure 'p2-make-structure) (install-p2-handler 'max 'p2-min/max) (install-p2-handler 'memq 'p2-memq) (install-p2-handler 'memql 'p2-memql) From ehuelsmann at common-lisp.net Sat Oct 9 20:50:41 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 09 Oct 2010 16:50:41 -0400 Subject: [armedbear-cvs] r12965 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 9 16:50:41 2010 New Revision: 12965 Log: Reduce our number of hash table implementations to 1 (from 4) by abstracting out the concept of "key equality" and "hash code retrieval" into a Comparator class. The other classes are left in place for now, but have been reduced to simple wrappers around the HashTable class. While at it, reformat HashTable.java (sorry about that - it obfuscates the functional changes). Modified: trunk/abcl/src/org/armedbear/lisp/EqHashTable.java trunk/abcl/src/org/armedbear/lisp/EqlHashTable.java trunk/abcl/src/org/armedbear/lisp/EqualHashTable.java trunk/abcl/src/org/armedbear/lisp/EqualpHashTable.java trunk/abcl/src/org/armedbear/lisp/HashTable.java Modified: trunk/abcl/src/org/armedbear/lisp/EqHashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/EqHashTable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/EqHashTable.java Sat Oct 9 16:50:41 2010 @@ -35,128 +35,10 @@ public final class EqHashTable extends HashTable { - private LispObject cachedKey; - private int cachedIndex; - - private int mask; - public EqHashTable(int size, LispObject rehashSize, LispObject rehashThreshold) { - super(calculateInitialCapacity(size), rehashSize, rehashThreshold); - mask = buckets.length - 1; - } - - @Override - public Symbol getTest() - { - return Symbol.EQ; - } - - @Override - public synchronized LispObject get(LispObject key) - { - final int index; - if (key == cachedKey) { - index = cachedIndex; - } else { - index = key.sxhash() & mask; - cachedKey = key; - cachedIndex = index; - } - HashEntry e = buckets[index]; - while (e != null) { - if (key == e.key) - return e.value; - e = e.next; - } - return null; - } - - @Override - public synchronized void put(LispObject key, LispObject value) - { - int index; - if (key == cachedKey) { - index = cachedIndex; - } else { - index = key.sxhash() & mask; - cachedKey = key; - cachedIndex = index; - } - HashEntry e = buckets[index]; - while (e != null) { - if (key == e.key) { - e.value = value; - return; - } - e = e.next; - } - // Not found. We need to add a new entry. - if (++count > threshold) { - rehash(); - // Need a new hash value to suit the bigger table. - index = key.sxhash() & mask; - cachedKey = key; - cachedIndex = index; - } - e = new HashEntry(key, value); - e.next = buckets[index]; - buckets[index] = e; - } - - @Override - public LispObject remove(LispObject key) - { - final int index; - if (key == cachedKey) { - index = cachedIndex; - } else { - index = key.sxhash() & mask; - cachedKey = key; - cachedIndex = index; - } - HashEntry e = buckets[index]; - HashEntry last = null; - while (e != null) { - if (key == e.key) { - if (last == null) - buckets[index] = e.next; - else - last.next = e.next; - --count; - return e.value; - } - last = e; - e = e.next; - } - return null; - } - - @Override - protected void rehash() - { - cachedKey = null; // Invalidate the cache! - HashEntry[] oldBuckets = buckets; - final int newCapacity = buckets.length * 2; - threshold = (int) (newCapacity * loadFactor); - buckets = new HashEntry[newCapacity]; - mask = buckets.length - 1; - for (int i = oldBuckets.length; i-- > 0;) { - HashEntry e = oldBuckets[i]; - while (e != null) { - final int index = e.key.sxhash() & mask; - HashEntry dest = buckets[index]; - if (dest != null) { - while (dest.next != null) - dest = dest.next; - dest.next = e; - } else - buckets[index] = e; - HashEntry next = e.next; - e.next = null; - e = next; - } - } + super(new Comparator(), calculateInitialCapacity(size), + rehashSize, rehashThreshold); } } Modified: trunk/abcl/src/org/armedbear/lisp/EqlHashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/EqlHashTable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/EqlHashTable.java Sat Oct 9 16:50:41 2010 @@ -35,110 +35,10 @@ public final class EqlHashTable extends HashTable { - private int mask; - public EqlHashTable(int size, LispObject rehashSize, LispObject rehashThreshold) { - super(calculateInitialCapacity(size), rehashSize, rehashThreshold); - mask = buckets.length - 1; - } - - @Override - public Symbol getTest() - { - return Symbol.EQL; - } - - @Override - public synchronized LispObject get(LispObject key) - { - HashEntry e = buckets[key.sxhash() & mask]; - while (e != null) - { - if (key.eql(e.key)) - return e.value; - e = e.next; - } - return null; - } - - @Override - public synchronized void put(LispObject key, LispObject value) - { - int index = key.sxhash() & mask; - HashEntry e = buckets[index]; - while (e != null) - { - if (key.eql(e.key)) - { - e.value = value; - return; - } - e = e.next; - } - // Not found. We need to add a new entry. - if (++count > threshold) - { - rehash(); - // Need a new hash value to suit the bigger table. - index = key.sxhash() & mask; - } - e = new HashEntry(key, value); - e.next = buckets[index]; - buckets[index] = e; - } - - @Override - public LispObject remove(LispObject key) - { - final int index = key.sxhash() & mask; - HashEntry e = buckets[index]; - HashEntry last = null; - while (e != null) - { - if (key.eql(e.key)) - { - if (last == null) - buckets[index] = e.next; - else - last.next = e.next; - --count; - return e.value; - } - last = e; - e = e.next; - } - return null; - } - - @Override - protected void rehash() - { - HashEntry[] oldBuckets = buckets; - int newCapacity = buckets.length * 2; - threshold = (int) (newCapacity * loadFactor); - buckets = new HashEntry[newCapacity]; - mask = buckets.length - 1; - for (int i = oldBuckets.length; i-- > 0;) - { - HashEntry e = oldBuckets[i]; - while (e != null) - { - final int index = e.key.sxhash() & mask; - HashEntry dest = buckets[index]; - if (dest != null) - { - while (dest.next != null) - dest = dest.next; - dest.next = e; - } - else - buckets[index] = e; - HashEntry next = e.next; - e.next = null; - e = next; - } - } + super(new EqlComparator(), calculateInitialCapacity(size), + rehashSize, rehashThreshold); } } Modified: trunk/abcl/src/org/armedbear/lisp/EqualHashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/EqualHashTable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/EqualHashTable.java Sat Oct 9 16:50:41 2010 @@ -35,110 +35,10 @@ public final class EqualHashTable extends HashTable { - private int mask; - public EqualHashTable(int size, LispObject rehashSize, LispObject rehashThreshold) { - super(calculateInitialCapacity(size), rehashSize, rehashThreshold); - mask = buckets.length - 1; - } - - @Override - public Symbol getTest() - { - return Symbol.EQUAL; - } - - @Override - public synchronized LispObject get(LispObject key) - { - HashEntry e = buckets[key.sxhash() & mask]; - while (e != null) - { - if (key == e.key || key.equal(e.key)) - return e.value; - e = e.next; - } - return null; - } - - @Override - public synchronized void put(LispObject key, LispObject value) - { - int index = key.sxhash() & mask; - HashEntry e = buckets[index]; - while (e != null) - { - if (key == e.key || key.equal(e.key)) - { - e.value = value; - return; - } - e = e.next; - } - // Not found. We need to add a new entry. - if (++count > threshold) - { - rehash(); - // Need a new hash value to suit the bigger table. - index = key.sxhash() & mask; - } - e = new HashEntry(key, value); - e.next = buckets[index]; - buckets[index] = e; - } - - @Override - public LispObject remove(LispObject key) - { - final int index = key.sxhash() & mask; - HashEntry e = buckets[index]; - HashEntry last = null; - while (e != null) - { - if (key == e.key || key.equal(e.key)) - { - if (last == null) - buckets[index] = e.next; - else - last.next = e.next; - --count; - return e.value; - } - last = e; - e = e.next; - } - return null; - } - - @Override - protected void rehash() - { - HashEntry[] oldBuckets = buckets; - int newCapacity = buckets.length * 2; - threshold = (int) (newCapacity * loadFactor); - buckets = new HashEntry[newCapacity]; - mask = buckets.length - 1; - for (int i = oldBuckets.length; i-- > 0;) - { - HashEntry e = oldBuckets[i]; - while (e != null) - { - final int index = e.key.sxhash() & mask; - HashEntry dest = buckets[index]; - if (dest != null) - { - while (dest.next != null) - dest = dest.next; - dest.next = e; - } - else - buckets[index] = e; - HashEntry next = e.next; - e.next = null; - e = next; - } - } + super(new EqualComparator(), calculateInitialCapacity(size), + rehashSize, rehashThreshold); } } Modified: trunk/abcl/src/org/armedbear/lisp/EqualpHashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/EqualpHashTable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/EqualpHashTable.java Sat Oct 9 16:50:41 2010 @@ -38,104 +38,6 @@ public EqualpHashTable(int size, LispObject rehashSize, LispObject rehashThreshold) { - super(size, rehashSize, rehashThreshold); - } - - @Override - public Symbol getTest() - { - return Symbol.EQUALP; - } - - @Override - public synchronized LispObject get(LispObject key) - { - final int index = key.psxhash() % buckets.length; - HashEntry e = buckets[index]; - while (e != null) - { - if (key.equalp(e.key)) - return e.value; - e = e.next; - } - return null; - } - - @Override - public synchronized void put(LispObject key, LispObject value) - { - int index = key.psxhash() % buckets.length; - HashEntry e = buckets[index]; - while (e != null) - { - if (key.equalp(e.key)) - { - e.value = value; - return; - } - e = e.next; - } - // Not found. We need to add a new entry. - if (++count > threshold) - { - rehash(); - // Need a new hash value to suit the bigger table. - index = key.psxhash() % buckets.length; - } - e = new HashEntry(key, value); - e.next = buckets[index]; - buckets[index] = e; - } - - @Override - public LispObject remove(LispObject key) - { - final int index = key.psxhash() % buckets.length; - HashEntry e = buckets[index]; - HashEntry last = null; - while (e != null) - { - if (key.equalp(e.key)) - { - if (last == null) - buckets[index] = e.next; - else - last.next = e.next; - --count; - return e.value; - } - last = e; - e = e.next; - } - return null; - } - - @Override - protected void rehash() - { - HashEntry[] oldBuckets = buckets; - int newCapacity = buckets.length * 2 + 1; - threshold = (int) (newCapacity * loadFactor); - buckets = new HashEntry[newCapacity]; - for (int i = oldBuckets.length; i-- > 0;) - { - HashEntry e = oldBuckets[i]; - while (e != null) - { - final int index = e.key.psxhash() % buckets.length; - HashEntry dest = buckets[index]; - if (dest != null) - { - while (dest.next != null) - dest = dest.next; - dest.next = e; - } - else - buckets[index] = e; - HashEntry next = e.next; - e.next = null; - e = next; - } - } + super(new EqualpComparator(), size, rehashSize, rehashThreshold); } } Modified: trunk/abcl/src/org/armedbear/lisp/HashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/HashTable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/HashTable.java Sat Oct 9 16:50:41 2010 @@ -30,276 +30,366 @@ * obligated to do so. If you do not wish to do so, delete this * exception statement from your version. */ - package org.armedbear.lisp; import static org.armedbear.lisp.Lisp.*; -public abstract class HashTable extends LispObject -{ - private static final int DEFAULT_SIZE = 16; +public abstract class HashTable extends LispObject { - protected static final float loadFactor = 0.75f; + private static final int DEFAULT_SIZE = 16; + protected static final float loadFactor = 0.75f; + protected final LispObject rehashSize; + protected final LispObject rehashThreshold; + // The rounded product of the capacity and the load factor. When the number + // of elements exceeds the threshold, the implementation calls rehash(). + protected int threshold; + // Array containing the actual key-value mappings. + protected HashEntry[] buckets; + // The number of key-value pairs. + protected int count; + private int mask; + final Comparator comparator; - protected final LispObject rehashSize; - protected final LispObject rehashThreshold; + protected HashTable(int size, LispObject rehashSize, + LispObject rehashThreshold) + { + protected HashTable(Comparator c, int size, LispObject rehashSize, + LispObject rehashThreshold) { + this.rehashSize = rehashSize; + this.rehashThreshold = rehashThreshold; + buckets = new HashEntry[size]; + threshold = (int) (size * loadFactor); + comparator = c; + mask = buckets.length - 1; + } - // The rounded product of the capacity and the load factor. When the number - // of elements exceeds the threshold, the implementation calls rehash(). - protected int threshold; + protected static int calculateInitialCapacity(int size) { + int capacity = 1; + while (capacity < size) { + capacity <<= 1; + } + return capacity; + } - // Array containing the actual key-value mappings. - protected HashEntry[] buckets; + public final LispObject getRehashSize() { + return rehashSize; + } - // The number of key-value pairs. - protected int count; + public final LispObject getRehashThreshold() { + return rehashThreshold; + } - protected HashTable(int size, LispObject rehashSize, - LispObject rehashThreshold) - { - this.rehashSize = rehashSize; - this.rehashThreshold = rehashThreshold; - buckets = new HashEntry[size]; - threshold = (int) (size * loadFactor); - } + public int getSize() { + return buckets.length; + } - protected static int calculateInitialCapacity(int size) - { - int capacity = 1; - while (capacity < size) - capacity <<= 1; - return capacity; - } + public int getCount() { + return count; + } - public final LispObject getRehashSize() - { - return rehashSize; - } + @Override + public LispObject typeOf() { + return Symbol.HASH_TABLE; + } - public final LispObject getRehashThreshold() - { - return rehashThreshold; - } + @Override + public LispObject classOf() { + return BuiltInClass.HASH_TABLE; + } - public int getSize() - { - return buckets.length; - } + @Override + public LispObject typep(LispObject type) { + if (type == Symbol.HASH_TABLE) { + return T; + } + if (type == BuiltInClass.HASH_TABLE) { + return T; + } + return super.typep(type); + } - public int getCount() - { - return count; - } + @Override + public boolean equalp(LispObject obj) { + if (this == obj) { + return true; + } + if (obj instanceof HashTable) { + HashTable ht = (HashTable) obj; + if (count != ht.count) { + return false; + } + if (getTest() != ht.getTest()) { + return false; + } + LispObject entries = ENTRIES(); + while (entries != NIL) { + LispObject entry = entries.car(); + LispObject key = entry.car(); + LispObject value = entry.cdr(); + if (!value.equalp(ht.get(key))) { + return false; + } + entries = entries.cdr(); + } + return true; + } + return false; + } - public abstract Symbol getTest(); + @Override + public LispObject getParts() { + LispObject parts = NIL; + for (int i = 0; i < buckets.length; i++) { + HashEntry e = buckets[i]; + while (e != null) { + parts = parts.push(new Cons("KEY [bucket " + i + "]", e.key)); + parts = parts.push(new Cons("VALUE", e.value)); + e = e.next; + } + } + return parts.nreverse(); + } - @Override - public LispObject typeOf() - { - return Symbol.HASH_TABLE; - } + public synchronized void clear() { + for (int i = buckets.length; i-- > 0;) { + buckets[i] = null; + } + count = 0; + } - @Override - public LispObject classOf() - { - return BuiltInClass.HASH_TABLE; - } + // gethash key hash-table &optional default => value, present-p + public synchronized LispObject gethash(LispObject key) { + LispObject value = get(key); + final LispObject presentp; + if (value == null) { + value = presentp = NIL; + } else { + presentp = T; + } + return LispThread.currentThread().setValues(value, presentp); + } - @Override - public LispObject typep(LispObject type) - { - if (type == Symbol.HASH_TABLE) - return T; - if (type == BuiltInClass.HASH_TABLE) - return T; - return super.typep(type); - } + // gethash key hash-table &optional default => value, present-p + public synchronized LispObject gethash(LispObject key, + LispObject defaultValue) { + LispObject value = get(key); + final LispObject presentp; + if (value == null) { + value = defaultValue; + presentp = NIL; + } else { + presentp = T; + } + return LispThread.currentThread().setValues(value, presentp); + } - @Override - public boolean equalp(LispObject obj) - { - if (this == obj) - return true; - if (obj instanceof HashTable) - { - HashTable ht = (HashTable) obj; - if (count != ht.count) - return false; - if (getTest() != ht.getTest()) - return false; - LispObject entries = ENTRIES(); - while (entries != NIL) - { - LispObject entry = entries.car(); - LispObject key = entry.car(); - LispObject value = entry.cdr(); - if (!value.equalp(ht.get(key))) - return false; - entries = entries.cdr(); - } - return true; - } - return false; - } + public synchronized LispObject gethash1(LispObject key) { + final LispObject value = get(key); + return value != null ? value : NIL; + } - @Override - public LispObject getParts() - { - LispObject parts = NIL; - for (int i = 0; i < buckets.length; i++) - { - HashEntry e = buckets[i]; - while (e != null) - { - parts = parts.push(new Cons("KEY [bucket " + i + "]", e.key)); - parts = parts.push(new Cons("VALUE", e.value)); - e = e.next; - } - } - return parts.nreverse(); - } + public synchronized LispObject puthash(LispObject key, LispObject newValue) { + put(key, newValue); + return newValue; + } - public synchronized void clear() - { - for (int i = buckets.length; i-- > 0;) - buckets[i] = null; - count = 0; - } + // remhash key hash-table => generalized-boolean + public synchronized LispObject remhash(LispObject key) { + // A value in a Lisp hash table can never be null, so... + return remove(key) != null ? T : NIL; + } - // gethash key hash-table &optional default => value, present-p - public synchronized LispObject gethash(LispObject key) + @Override + public String writeToString() { + if (Symbol.PRINT_READABLY.symbolValue(LispThread.currentThread()) != NIL) { + error(new PrintNotReadable(list(Keyword.OBJECT, this))); + return null; // Not reached. + } + StringBuilder sb = new StringBuilder(getTest().writeToString()); + sb.append(' '); + sb.append(Symbol.HASH_TABLE.writeToString()); + sb.append(' '); + sb.append(count); + if (count == 1) { + sb.append(" entry"); + } else { + sb.append(" entries"); + } + sb.append(", "); + sb.append(buckets.length); + sb.append(" buckets"); + return unreadableString(sb.toString()); + } - { - LispObject value = get(key); - final LispObject presentp; - if (value == null) - value = presentp = NIL; - else - presentp = T; - return LispThread.currentThread().setValues(value, presentp); - } - - // gethash key hash-table &optional default => value, present-p - public synchronized LispObject gethash(LispObject key, - LispObject defaultValue) + public Symbol getTest() { + return comparator.getTest(); + } - { - LispObject value = get(key); - final LispObject presentp; - if (value == null) - { - value = defaultValue; - presentp = NIL; - } - else - presentp = T; - return LispThread.currentThread().setValues(value, presentp); - } + synchronized public LispObject get(LispObject key) { + int index = comparator.hash(key) & mask; + HashEntry e = buckets[index]; + while (e != null) { + if (comparator.keysEqual(key, e.key)) { + return e.value; + } + e = e.next; + } + return null; + } + + synchronized public void put(LispObject key, LispObject value) { + int index = comparator.hash(key) & mask; + for (HashEntry e = buckets[index]; e != null; e = e.next) { + if (comparator.keysEqual(key, e.key)) { + e.value = value; + return; + } + } + // Not found. We need to add a new entry. + if (++count > threshold) { + rehash(); + // Need a new hash value to suit the bigger table. + index = comparator.hash(key) & mask; + } + buckets[index] = new HashEntry(key, value, buckets[index]); + } - public synchronized LispObject gethash1(LispObject key) + synchronized public LispObject remove(LispObject key) { + int index = comparator.hash(key) & mask; - { - final LispObject value = get(key); - return value != null ? value : NIL; - } + HashEntry e = buckets[index]; + HashEntry last = null; + while (e != null) { + if (comparator.keysEqual(key, e.key)) { + if (last == null) { + buckets[index] = e.next; + } else { + last.next = e.next; + } + --count; + return e.value; + } + last = e; + e = e.next; + } + return null; + } - public synchronized LispObject puthash(LispObject key, LispObject newValue) + synchronized protected void rehash() { + final int newCapacity = buckets.length * 2; + threshold = (int) (newCapacity * loadFactor); + mask = newCapacity - 1; + HashEntry[] newBuckets = new HashEntry[newCapacity]; + + for (int i = buckets.length; i-- > 0;) { + HashEntry e = buckets[i]; + while (e != null) { + final int index = comparator.hash(e.key) & mask; + newBuckets[index] = new HashEntry(e.key,e.value, newBuckets[index]); + e = e.next; + } + } + buckets = newBuckets; + } - { - put(key, newValue); - return newValue; - } + // Returns a list of (key . value) pairs. + public LispObject ENTRIES() { + LispObject list = NIL; + for (int i = buckets.length; i-- > 0;) { + HashEntry e = buckets[i]; + while (e != null) { + list = new Cons(new Cons(e.key, e.value), list); + e = e.next; + } + } + return list; + } - // remhash key hash-table => generalized-boolean - public synchronized LispObject remhash(LispObject key) + public LispObject MAPHASH(LispObject function) { + for (int i = buckets.length; i-- > 0;) { + HashEntry e = buckets[i]; + while (e != null) { + function.execute(e.key, e.value); + e = e.next; + } + } + return NIL; + } - { - // A value in a Lisp hash table can never be null, so... - return remove(key) != null ? T : NIL; - } + protected static class Comparator { + Symbol getTest() { + return Symbol.EQ; + } + + boolean keysEqual(LispObject key1, LispObject key2) { + return key1 == key2; + } + + int hash(LispObject key) { + return key.sxhash(); + } + } - @Override - public String writeToString() - { - if (Symbol.PRINT_READABLY.symbolValue(LispThread.currentThread()) != NIL) - { - error(new PrintNotReadable(list(Keyword.OBJECT, this))); - return null; // Not reached. - } - StringBuilder sb = new StringBuilder(getTest().writeToString()); - sb.append(' '); - sb.append(Symbol.HASH_TABLE.writeToString()); - sb.append(' '); - sb.append(count); - if (count == 1) - sb.append(" entry"); - else - sb.append(" entries"); - sb.append(", "); - sb.append(buckets.length); - sb.append(" buckets"); - return unreadableString(sb.toString()); - } - - public abstract LispObject get(LispObject key); - - public abstract void put(LispObject key, LispObject value) - ; + protected static class EqlComparator extends Comparator { + @Override + Symbol getTest() { + return Symbol.EQL; + } + + @Override + boolean keysEqual(LispObject key1, LispObject key2) { + return key1.eql(key2); + } + } - public abstract LispObject remove(LispObject key); + protected static class EqualComparator extends Comparator { + @Override + Symbol getTest() { + return Symbol.EQUAL; + } + + @Override + boolean keysEqual(LispObject key1, LispObject key2) { + return key1.equal(key2); + } + } - protected abstract void rehash(); + protected static class EqualpComparator extends Comparator { + @Override + Symbol getTest() { + return Symbol.EQUALP; + } + + @Override + boolean keysEqual(LispObject key1, LispObject key2) { + return key1.equalp(key2); + } + + @Override + int hash(LispObject key) { + return key.psxhash(); + } + } - // Returns a list of (key . value) pairs. - public LispObject ENTRIES() - { - LispObject list = NIL; - for (int i = buckets.length; i-- > 0;) - { - HashEntry e = buckets[i]; - while (e != null) - { - list = new Cons(new Cons(e.key, e.value), list); - e = e.next; - } - } - return list; - } + protected static class HashEntry { - public LispObject MAPHASH(LispObject function) - { - for (int i = buckets.length; i-- > 0;) - { - HashEntry e = buckets[i]; - while (e != null) - { - function.execute(e.key, e.value); - e = e.next; - } - } - return NIL; - } + LispObject key; + LispObject value; + HashEntry next; + + HashEntry(LispObject key, LispObject value, HashEntry next) { + this.key = key; + this.value = value; + this.next = next; + } + } - protected static class HashEntry - { - LispObject key; - LispObject value; - HashEntry next; - - HashEntry(LispObject key, LispObject value) - { - this.key = key; - this.value = value; - } - } - - // For EQUALP hash tables. - @Override - public int psxhash() - { - long result = 2062775257; // Chosen at random. - result = mix(result, count); - result = mix(result, getTest().sxhash()); - return (int) (result & 0x7fffffff); - } + // For EQUALP hash tables. + @Override + public int psxhash() { + long result = 2062775257; // Chosen at random. + result = mix(result, count); + result = mix(result, getTest().sxhash()); + return (int) (result & 0x7fffffff); + } } From ehuelsmann at common-lisp.net Sat Oct 9 20:58:58 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 09 Oct 2010 16:58:58 -0400 Subject: [armedbear-cvs] r12966 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 9 16:58:58 2010 New Revision: 12966 Log: Repair HashTable.java, broken due to faulty conflict resolution. Modified: trunk/abcl/src/org/armedbear/lisp/HashTable.java Modified: trunk/abcl/src/org/armedbear/lisp/HashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/HashTable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/HashTable.java Sat Oct 9 16:58:58 2010 @@ -50,9 +50,6 @@ private int mask; final Comparator comparator; - protected HashTable(int size, LispObject rehashSize, - LispObject rehashThreshold) - { protected HashTable(Comparator c, int size, LispObject rehashSize, LispObject rehashThreshold) { this.rehashSize = rehashSize; From ehuelsmann at common-lisp.net Sat Oct 9 21:39:29 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 09 Oct 2010 17:39:29 -0400 Subject: [armedbear-cvs] r12967 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 9 17:39:29 2010 New Revision: 12967 Log: Convert HashTable synchronized access to read/write locked access through ReentrantReadWriteLock: this will allow multiple readers across threads. Also add my name to the copyright notice. Modified: trunk/abcl/src/org/armedbear/lisp/HashTable.java Modified: trunk/abcl/src/org/armedbear/lisp/HashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/HashTable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/HashTable.java Sat Oct 9 17:39:29 2010 @@ -2,6 +2,7 @@ * HashTable.java * * Copyright (C) 2002-2007 Peter Graves + * Copyright (C) 2010 Erik Huelsmann * $Id$ * * This program is free software; you can redistribute it and/or @@ -32,11 +33,11 @@ */ package org.armedbear.lisp; +import java.util.concurrent.locks.ReentrantReadWriteLock; import static org.armedbear.lisp.Lisp.*; public abstract class HashTable extends LispObject { - private static final int DEFAULT_SIZE = 16; protected static final float loadFactor = 0.75f; protected final LispObject rehashSize; protected final LispObject rehashThreshold; @@ -49,6 +50,7 @@ protected int count; private int mask; final Comparator comparator; + final private ReentrantReadWriteLock lock = new ReentrantReadWriteLock(); protected HashTable(Comparator c, int size, LispObject rehashSize, LispObject rehashThreshold) { @@ -147,15 +149,18 @@ return parts.nreverse(); } - public synchronized void clear() { - for (int i = buckets.length; i-- > 0;) { - buckets[i] = null; + public void clear() { + lock.writeLock().lock(); + try { + buckets = new HashEntry[buckets.length]; + count = 0; + } finally { + lock.writeLock().unlock(); } - count = 0; } // gethash key hash-table &optional default => value, present-p - public synchronized LispObject gethash(LispObject key) { + public LispObject gethash(LispObject key) { LispObject value = get(key); final LispObject presentp; if (value == null) { @@ -167,8 +172,7 @@ } // gethash key hash-table &optional default => value, present-p - public synchronized LispObject gethash(LispObject key, - LispObject defaultValue) { + public LispObject gethash(LispObject key, LispObject defaultValue) { LispObject value = get(key); final LispObject presentp; if (value == null) { @@ -180,18 +184,18 @@ return LispThread.currentThread().setValues(value, presentp); } - public synchronized LispObject gethash1(LispObject key) { + public LispObject gethash1(LispObject key) { final LispObject value = get(key); return value != null ? value : NIL; } - public synchronized LispObject puthash(LispObject key, LispObject newValue) { + public LispObject puthash(LispObject key, LispObject newValue) { put(key, newValue); return newValue; } // remhash key hash-table => generalized-boolean - public synchronized LispObject remhash(LispObject key) { + public LispObject remhash(LispObject key) { // A value in a Lisp hash table can never be null, so... return remove(key) != null ? T : NIL; } @@ -222,71 +226,91 @@ return comparator.getTest(); } - synchronized public LispObject get(LispObject key) { - int index = comparator.hash(key) & mask; - HashEntry e = buckets[index]; - while (e != null) { - if (comparator.keysEqual(key, e.key)) { - return e.value; - } - e = e.next; - } - return null; - } - - synchronized public void put(LispObject key, LispObject value) { - int index = comparator.hash(key) & mask; - for (HashEntry e = buckets[index]; e != null; e = e.next) { - if (comparator.keysEqual(key, e.key)) { - e.value = value; - return; - } - } - // Not found. We need to add a new entry. - if (++count > threshold) { - rehash(); - // Need a new hash value to suit the bigger table. - index = comparator.hash(key) & mask; - } - buckets[index] = new HashEntry(key, value, buckets[index]); - } - - synchronized public LispObject remove(LispObject key) { - int index = comparator.hash(key) & mask; - - HashEntry e = buckets[index]; - HashEntry last = null; - while (e != null) { - if (comparator.keysEqual(key, e.key)) { - if (last == null) { - buckets[index] = e.next; - } else { - last.next = e.next; + public LispObject get(LispObject key) { + lock.readLock().lock(); + try { + int index = comparator.hash(key) & mask; + HashEntry e = buckets[index]; + while (e != null) { + if (comparator.keysEqual(key, e.key)) { + return e.value; } - --count; - return e.value; + e = e.next; } - last = e; - e = e.next; + return null; + } finally { + lock.readLock().unlock(); } - return null; } - synchronized protected void rehash() { - final int newCapacity = buckets.length * 2; - threshold = (int) (newCapacity * loadFactor); - mask = newCapacity - 1; - HashEntry[] newBuckets = new HashEntry[newCapacity]; + public void put(LispObject key, LispObject value) { + lock.writeLock().lock(); + try { + int index = comparator.hash(key) & mask; + for (HashEntry e = buckets[index]; e != null; e = e.next) { + if (comparator.keysEqual(key, e.key)) { + e.value = value; + return; + } + } + // Not found. We need to add a new entry. + if (++count > threshold) { + rehash(); + // Need a new hash value to suit the bigger table. + index = comparator.hash(key) & mask; + } + buckets[index] = new HashEntry(key, value, buckets[index]); + } finally { + lock.writeLock().unlock(); + } + } - for (int i = buckets.length; i-- > 0;) { - HashEntry e = buckets[i]; + public LispObject remove(LispObject key) { + lock.writeLock().lock(); + try { + int index = comparator.hash(key) & mask; + + HashEntry e = buckets[index]; + HashEntry last = null; while (e != null) { - final int index = comparator.hash(e.key) & mask; - newBuckets[index] = new HashEntry(e.key,e.value, newBuckets[index]); + if (comparator.keysEqual(key, e.key)) { + if (last == null) { + buckets[index] = e.next; + } else { + last.next = e.next; + } + --count; + return e.value; + } + last = e; e = e.next; } + return null; + } finally { + lock.writeLock().unlock(); + } + } + + protected void rehash() { + lock.writeLock().lock(); + try { + final int newCapacity = buckets.length * 2; + threshold = (int) (newCapacity * loadFactor); + mask = newCapacity - 1; + HashEntry[] newBuckets = new HashEntry[newCapacity]; + + for (int i = buckets.length; i-- > 0;) { + HashEntry e = buckets[i]; + while (e != null) { + final int index = comparator.hash(e.key) & mask; + newBuckets[index] = new HashEntry(e.key, e.value, newBuckets[index]); + e = e.next; + } + } + buckets = newBuckets; + } finally { + lock.writeLock().unlock(); } - buckets = newBuckets; } // Returns a list of (key . value) pairs. @@ -314,6 +338,7 @@ } protected static class Comparator { + Symbol getTest() { return Symbol.EQ; } @@ -328,6 +353,7 @@ } protected static class EqlComparator extends Comparator { + @Override Symbol getTest() { return Symbol.EQL; @@ -340,6 +366,7 @@ } protected static class EqualComparator extends Comparator { + @Override Symbol getTest() { return Symbol.EQUAL; @@ -352,6 +379,7 @@ } protected static class EqualpComparator extends Comparator { + @Override Symbol getTest() { return Symbol.EQUALP; From ehuelsmann at common-lisp.net Sat Oct 9 22:59:02 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 09 Oct 2010 18:59:02 -0400 Subject: [armedbear-cvs] r12968 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 9 18:59:01 2010 New Revision: 12968 Log: Factor out getEntry from get() and put(). Also, declare the 'buckets' field volatile and decide not to use read-locking in some cases. Modified: trunk/abcl/src/org/armedbear/lisp/HashTable.java Modified: trunk/abcl/src/org/armedbear/lisp/HashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/HashTable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/HashTable.java Sat Oct 9 18:59:01 2010 @@ -33,6 +33,7 @@ */ package org.armedbear.lisp; +import java.util.concurrent.ConcurrentHashMap; import java.util.concurrent.locks.ReentrantReadWriteLock; import static org.armedbear.lisp.Lisp.*; @@ -45,7 +46,10 @@ // of elements exceeds the threshold, the implementation calls rehash(). protected int threshold; // Array containing the actual key-value mappings. - protected HashEntry[] buckets; + + @SuppressWarnings("VolatileArrayField") + protected volatile HashEntry[] buckets; + // The number of key-value pairs. protected int count; private int mask; @@ -137,9 +141,11 @@ @Override public LispObject getParts() { + // No need to take out a read lock, for the same reason as MAPHASH + HashEntry[] b = buckets; LispObject parts = NIL; - for (int i = 0; i < buckets.length; i++) { - HashEntry e = buckets[i]; + for (int i = 0; i < b.length; i++) { + HashEntry e = b[i]; while (e != null) { parts = parts.push(new Cons("KEY [bucket " + i + "]", e.key)); parts = parts.push(new Cons("VALUE", e.value)); @@ -226,18 +232,23 @@ return comparator.getTest(); } + protected HashEntry getEntry(LispObject key) { + int index = comparator.hash(key) & mask; + HashEntry e = buckets[index]; + while (e != null) { + if (comparator.keysEqual(key, e.key)) { + return e; + } + e = e.next; + } + return null; + } + public LispObject get(LispObject key) { lock.readLock().lock(); try { - int index = comparator.hash(key) & mask; - HashEntry e = buckets[index]; - while (e != null) { - if (comparator.keysEqual(key, e.key)) { - return e.value; - } - e = e.next; - } - return null; + HashEntry e = getEntry(key); + return (e == null) ? null : e.value; } finally { lock.readLock().unlock(); } @@ -246,20 +257,18 @@ public void put(LispObject key, LispObject value) { lock.writeLock().lock(); try { - int index = comparator.hash(key) & mask; - for (HashEntry e = buckets[index]; e != null; e = e.next) { - if (comparator.keysEqual(key, e.key)) { - e.value = value; - return; + HashEntry e = getEntry(key); + if (e == null) { + e.value = value; + } else { + // Not found. We need to add a new entry. + if (++count > threshold) { + rehash(); } + + int index = comparator.hash(key) & mask; + buckets[index] = new HashEntry(key, value, buckets[index]); } - // Not found. We need to add a new entry. - if (++count > threshold) { - rehash(); - // Need a new hash value to suit the bigger table. - index = comparator.hash(key) & mask; - } - buckets[index] = new HashEntry(key, value, buckets[index]); } finally { lock.writeLock().unlock(); } @@ -315,9 +324,11 @@ // Returns a list of (key . value) pairs. public LispObject ENTRIES() { + // No need to take out a read lock, for the same reason as MAPHASH + HashEntry[] b = buckets; LispObject list = NIL; - for (int i = buckets.length; i-- > 0;) { - HashEntry e = buckets[i]; + for (int i = b.length; i-- > 0;) { + HashEntry e = b[i]; while (e != null) { list = new Cons(new Cons(e.key, e.value), list); e = e.next; @@ -327,8 +338,13 @@ } public LispObject MAPHASH(LispObject function) { - for (int i = buckets.length; i-- > 0;) { - HashEntry e = buckets[i]; + // Don't take out a read lock: it can't be upgraded to a write + // lock, which would block the scenario where put() is called to + // set the value of the current entry + + HashEntry[] b = buckets; + for (int i = b.length; i-- > 0;) { + HashEntry e = b[i]; while (e != null) { function.execute(e.key, e.value); e = e.next; From ehuelsmann at common-lisp.net Sat Oct 9 23:28:32 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 09 Oct 2010 19:28:32 -0400 Subject: [armedbear-cvs] r12969 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Oct 9 19:28:31 2010 New Revision: 12969 Log: Implement nearly lock-free hash reader functionality, by looking really well at ConcurrentHashMap - agreed. Modified: trunk/abcl/src/org/armedbear/lisp/HashTable.java Modified: trunk/abcl/src/org/armedbear/lisp/HashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/HashTable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/HashTable.java Sat Oct 9 19:28:31 2010 @@ -33,8 +33,7 @@ */ package org.armedbear.lisp; -import java.util.concurrent.ConcurrentHashMap; -import java.util.concurrent.locks.ReentrantReadWriteLock; +import java.util.concurrent.locks.ReentrantLock; import static org.armedbear.lisp.Lisp.*; public abstract class HashTable extends LispObject { @@ -46,15 +45,12 @@ // of elements exceeds the threshold, the implementation calls rehash(). protected int threshold; // Array containing the actual key-value mappings. - @SuppressWarnings("VolatileArrayField") protected volatile HashEntry[] buckets; - // The number of key-value pairs. - protected int count; - private int mask; + protected volatile int count; final Comparator comparator; - final private ReentrantReadWriteLock lock = new ReentrantReadWriteLock(); + final private ReentrantLock lock = new ReentrantLock(); protected HashTable(Comparator c, int size, LispObject rehashSize, LispObject rehashThreshold) { @@ -63,7 +59,6 @@ buckets = new HashEntry[size]; threshold = (int) (size * loadFactor); comparator = c; - mask = buckets.length - 1; } protected static int calculateInitialCapacity(int size) { @@ -156,12 +151,12 @@ } public void clear() { - lock.writeLock().lock(); + lock.lock(); try { buckets = new HashEntry[buckets.length]; count = 0; } finally { - lock.writeLock().unlock(); + lock.unlock(); } } @@ -233,8 +228,8 @@ } protected HashEntry getEntry(LispObject key) { - int index = comparator.hash(key) & mask; - HashEntry e = buckets[index]; + HashEntry[] b = buckets; + HashEntry e = b[comparator.hash(key) & (b.length - 1)]; while (e != null) { if (comparator.keysEqual(key, e.key)) { return e; @@ -245,20 +240,26 @@ } public LispObject get(LispObject key) { - lock.readLock().lock(); + HashEntry e = getEntry(key); + LispObject v = (e == null) ? null : e.value; + + if (e == null || v != null) { + return v; + } + + lock.lock(); try { - HashEntry e = getEntry(key); - return (e == null) ? null : e.value; + return e.value; } finally { - lock.readLock().unlock(); + lock.unlock(); } } public void put(LispObject key, LispObject value) { - lock.writeLock().lock(); + lock.lock(); try { HashEntry e = getEntry(key); - if (e == null) { + if (e != null) { e.value = value; } else { // Not found. We need to add a new entry. @@ -266,18 +267,18 @@ rehash(); } - int index = comparator.hash(key) & mask; + int index = comparator.hash(key) & (buckets.length - 1); buckets[index] = new HashEntry(key, value, buckets[index]); } } finally { - lock.writeLock().unlock(); + lock.unlock(); } } public LispObject remove(LispObject key) { - lock.writeLock().lock(); + lock.lock(); try { - int index = comparator.hash(key) & mask; + int index = comparator.hash(key) & (buckets.length - 1); HashEntry e = buckets[index]; HashEntry last = null; @@ -296,16 +297,16 @@ } return null; } finally { - lock.writeLock().unlock(); + lock.unlock(); } } protected void rehash() { - lock.writeLock().lock(); + lock.lock(); try { final int newCapacity = buckets.length * 2; threshold = (int) (newCapacity * loadFactor); - mask = newCapacity - 1; + int mask = newCapacity - 1; HashEntry[] newBuckets = new HashEntry[newCapacity]; for (int i = buckets.length; i-- > 0;) { @@ -318,7 +319,7 @@ } buckets = newBuckets; } finally { - lock.writeLock().unlock(); + lock.unlock(); } } @@ -415,7 +416,7 @@ protected static class HashEntry { LispObject key; - LispObject value; + volatile LispObject value; HashEntry next; HashEntry(LispObject key, LispObject value, HashEntry next) { From ehuelsmann at common-lisp.net Sun Oct 10 09:15:53 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 10 Oct 2010 05:15:53 -0400 Subject: [armedbear-cvs] r12970 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Oct 10 05:15:49 2010 New Revision: 12970 Log: Remove Remove now obsolete hash table specializations; in order to be able to instantiate HashTable directly remove the 'abstract' modifier from the class; there are no abstract methods anymore. Removed: trunk/abcl/src/org/armedbear/lisp/EqHashTable.java trunk/abcl/src/org/armedbear/lisp/EqlHashTable.java trunk/abcl/src/org/armedbear/lisp/EqualHashTable.java trunk/abcl/src/org/armedbear/lisp/EqualpHashTable.java Modified: trunk/abcl/src/org/armedbear/lisp/HashTable.java trunk/abcl/src/org/armedbear/lisp/HashTableFunctions.java trunk/abcl/src/org/armedbear/lisp/Pathname.java Modified: trunk/abcl/src/org/armedbear/lisp/HashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/HashTable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/HashTable.java Sun Oct 10 05:15:49 2010 @@ -36,7 +36,7 @@ import java.util.concurrent.locks.ReentrantLock; import static org.armedbear.lisp.Lisp.*; -public abstract class HashTable extends LispObject { +public class HashTable extends LispObject { protected static final float loadFactor = 0.75f; protected final LispObject rehashSize; @@ -69,6 +69,26 @@ return capacity; } + public static HashTable newEqHashTable(int size, LispObject rehashSize, + LispObject rehashThreshold) { + return new HashTable(new Comparator(), size, rehashSize, rehashThreshold); + } + + public static HashTable newEqlHashTable(int size, LispObject rehashSize, + LispObject rehashThreshold) { + return new HashTable(new EqlComparator(), size, rehashSize, rehashThreshold); + } + + public static HashTable newEqualHashTable(int size, LispObject rehashSize, + LispObject rehashThreshold) { + return new HashTable(new EqualComparator(), size, rehashSize, rehashThreshold); + } + + public static LispObject newEqualpHashTable(int size, LispObject rehashSize, + LispObject rehashThreshold) { + return new HashTable(new EqualpComparator(), size, rehashSize, rehashThreshold); + } + public final LispObject getRehashSize() { return rehashSize; } Modified: trunk/abcl/src/org/armedbear/lisp/HashTableFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/HashTableFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/HashTableFunctions.java Sun Oct 10 05:15:49 2010 @@ -57,13 +57,13 @@ { final int n = Fixnum.getValue(size); if (test == FUNCTION_EQL || test == NIL) - return new EqlHashTable(n, rehashSize, rehashThreshold); + return HashTable.newEqlHashTable(n, rehashSize, rehashThreshold); if (test == FUNCTION_EQ) - return new EqHashTable(n, rehashSize, rehashThreshold); + return HashTable.newEqHashTable(n, rehashSize, rehashThreshold); if (test == FUNCTION_EQUAL) - return new EqualHashTable(n, rehashSize, rehashThreshold); + return HashTable.newEqualHashTable(n, rehashSize, rehashThreshold); if (test == FUNCTION_EQUALP) - return new EqualpHashTable(n, rehashSize, rehashThreshold); + return HashTable.newEqualpHashTable(n, rehashSize, rehashThreshold); return error(new LispError("Unsupported test for MAKE-HASH-TABLE: " + test.writeToString())); } Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Sun Oct 10 05:15:49 2010 @@ -925,8 +925,8 @@ } // A logical host is represented as the string that names it. // (defvar *logical-pathname-translations* (make-hash-table :test 'equal)) - public static EqualHashTable LOGICAL_PATHNAME_TRANSLATIONS = - new EqualHashTable(64, NIL, NIL); + public static HashTable LOGICAL_PATHNAME_TRANSLATIONS = + HashTable.newEqualHashTable(64, NIL, NIL); private static final Symbol _LOGICAL_PATHNAME_TRANSLATIONS_ = exportSpecial("*LOGICAL-PATHNAME-TRANSLATIONS*", PACKAGE_SYS, LOGICAL_PATHNAME_TRANSLATIONS); From ehuelsmann at common-lisp.net Sun Oct 10 15:48:49 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 10 Oct 2010 11:48:49 -0400 Subject: [armedbear-cvs] r12971 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Oct 10 11:48:48 2010 New Revision: 12971 Log: Small performance improvement for non-EQ hash tables; don't use comparator when key and HashEntry.key are the same object. Along the same lines, compare the keys *only* if the hash values are equal. Modified: trunk/abcl/src/org/armedbear/lisp/HashTable.java Modified: trunk/abcl/src/org/armedbear/lisp/HashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/HashTable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/HashTable.java Sun Oct 10 11:48:48 2010 @@ -249,9 +249,11 @@ protected HashEntry getEntry(LispObject key) { HashEntry[] b = buckets; - HashEntry e = b[comparator.hash(key) & (b.length - 1)]; + int hash = comparator.hash(key); + HashEntry e = b[hash & (b.length - 1)]; while (e != null) { - if (comparator.keysEqual(key, e.key)) { + if (hash == e.hash && + (key == e.key || comparator.keysEqual(key, e.key))) { return e; } e = e.next; @@ -287,8 +289,9 @@ rehash(); } - int index = comparator.hash(key) & (buckets.length - 1); - buckets[index] = new HashEntry(key, value, buckets[index]); + int hash = comparator.hash(key); + int index = hash & (buckets.length - 1); + buckets[index] = new HashEntry(key, hash, value, buckets[index]); } } finally { lock.unlock(); @@ -333,7 +336,8 @@ HashEntry e = buckets[i]; while (e != null) { final int index = comparator.hash(e.key) & mask; - newBuckets[index] = new HashEntry(e.key, e.value, newBuckets[index]); + newBuckets[index] = new HashEntry(e.key, e.hash, e.value, + newBuckets[index]); e = e.next; } } @@ -436,11 +440,13 @@ protected static class HashEntry { LispObject key; + int hash; volatile LispObject value; HashEntry next; - HashEntry(LispObject key, LispObject value, HashEntry next) { + HashEntry(LispObject key, int hash, LispObject value, HashEntry next) { this.key = key; + this.hash = hash; this.value = value; this.next = next; } From ehuelsmann at common-lisp.net Sun Oct 10 15:52:05 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 10 Oct 2010 11:52:05 -0400 Subject: [armedbear-cvs] r12972 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Oct 10 11:52:04 2010 New Revision: 12972 Log: Preallocate package sizes large enough to hold all the symbols inserted during the boot process. Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Sun Oct 10 11:52:04 2010 @@ -54,23 +54,23 @@ // Packages. public static final Package PACKAGE_CL = - Packages.createPackage("COMMON-LISP", 1024); + Packages.createPackage("COMMON-LISP", 2048); // EH 10-10-2010: Actual number = 1014 public static final Package PACKAGE_CL_USER = Packages.createPackage("COMMON-LISP-USER", 1024); public static final Package PACKAGE_KEYWORD = Packages.createPackage("KEYWORD", 1024); public static final Package PACKAGE_SYS = - Packages.createPackage("SYSTEM"); + Packages.createPackage("SYSTEM", 2048); // EH 10-10-2010: Actual number = 1216 public static final Package PACKAGE_MOP = - Packages.createPackage("MOP"); + Packages.createPackage("MOP", 512); // EH 10-10-2010: Actual number = 277 public static final Package PACKAGE_TPL = - Packages.createPackage("TOP-LEVEL"); + Packages.createPackage("TOP-LEVEL", 128); // EH 10-10-2010: Actual number = 6 public static final Package PACKAGE_EXT = - Packages.createPackage("EXTENSIONS"); + Packages.createPackage("EXTENSIONS", 256); // EH 10-10-2010: Actual number = 131 public static final Package PACKAGE_JVM = - Packages.createPackage("JVM"); + Packages.createPackage("JVM", 2048); // EH 10-10-2010: Actual number = 1518 public static final Package PACKAGE_LOOP = - Packages.createPackage("LOOP"); + Packages.createPackage("LOOP", 512); // EH 10-10-2010: Actual number = 305 public static final Package PACKAGE_PROF = Packages.createPackage("PROFILER"); public static final Package PACKAGE_JAVA = @@ -86,7 +86,7 @@ public static final Package PACKAGE_PRECOMPILER = Packages.createPackage("PRECOMPILER"); public static final Package PACKAGE_SEQUENCE = - Packages.createPackage("SEQUENCE"); + Packages.createPackage("SEQUENCE", 128); // EH 10-10-2010: Actual number 62 @DocString(name="nil") From ehuelsmann at common-lisp.net Thu Oct 14 11:47:32 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 14 Oct 2010 07:47:32 -0400 Subject: [armedbear-cvs] r12973 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Oct 14 07:47:28 2010 New Revision: 12973 Log: Fix an issue with running ABCL on Oracle JRockit JVM! Patch by: Joel Borggr?n-Franck joel (dot) borggren (dot) franck gmail.com Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Thu Oct 14 07:47:28 2010 @@ -2004,6 +2004,9 @@ ZipEntry entry = jarFile.getEntry(entryPath); if (entry != null) { // ensure this isn't a directory + if (entry.isDirectory()) { + return NIL; + } try { InputStream input = jarFile.getInputStream(entry); if (input != null) { From mevenson at common-lisp.net Fri Oct 15 05:06:45 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 15 Oct 2010 01:06:45 -0400 Subject: [armedbear-cvs] r12974 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Oct 15 01:06:42 2010 New Revision: 12974 Log: Let truename() possibly signal an error on r12793 JRockit fix. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Fri Oct 15 01:06:42 2010 @@ -2005,7 +2005,7 @@ if (entry != null) { // ensure this isn't a directory if (entry.isDirectory()) { - return NIL; + break jarfile; } try { InputStream input = jarFile.getInputStream(entry); From vvoutilainen at common-lisp.net Sat Oct 16 19:03:41 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sat, 16 Oct 2010 15:03:41 -0400 Subject: [armedbear-cvs] r12975 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sat Oct 16 15:03:40 2010 New Revision: 12975 Log: Fix breakage of repl. Commands with parameters work again now. Keywords are not interpreted as commands, as per the previous patch for that. Modified: trunk/abcl/src/org/armedbear/lisp/top-level.lisp Modified: trunk/abcl/src/org/armedbear/lisp/top-level.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/top-level.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/top-level.lisp Sat Oct 16 15:03:40 2010 @@ -44,6 +44,7 @@ (import '(sys::%format sys::list-traced-functions sys::trace-1 sys::untrace-1 sys::untrace-all)) (defvar *null-cmd* (gensym)) +(defvar *handled-cmd* (gensym)) (defvar *command-char* #\:) @@ -376,17 +377,17 @@ (defun read-cmd (stream) (let ((c (peek-char-non-whitespace stream))) - (if (eql c #\Newline) - (progn - (read-line stream) - *null-cmd*) - (let ((input (read stream nil))) - (if (not (keywordp input)) - input - (let ((name (string-downcase (symbol-name input)))) - (if (find-command name) - (concatenate 'string ":" name) - input))))))) + (cond ((eql c *command-char*) + (let* ((input (read-line stream)) + (name (symbol-name (read-from-string input)))) + (if (find-command name) + (progn (process-cmd input) *handled-cmd*) + (read-from-string (concatenate 'string ":" name))))) + ((eql c #\newline) + (read-line stream) + *null-cmd*) + (t + (read stream nil))))) (defun repl-read-form-fun (in out) (loop @@ -396,7 +397,8 @@ (setf (charpos out) 0) (unless (eq form *null-cmd*) (incf *cmd-number*)) - (cond ((process-cmd form)) + (cond ((or (eq form *null-cmd*) + (eq form *handled-cmd*))) ((and (> *debug-level* 0) (fixnump form)) (let ((n form) From ehuelsmann at common-lisp.net Sat Oct 16 21:21:36 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 16 Oct 2010 17:21:36 -0400 Subject: [armedbear-cvs] r12976 - public_html Message-ID: Author: ehuelsmann Date: Sat Oct 16 17:21:33 2010 New Revision: 12976 Log: Mention the ABCL-DEV blog. Suggested by: David Kirkman Modified: public_html/index.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Sat Oct 16 17:21:33 2010 @@ -97,6 +97,7 @@
    • FAQ
      • +
    • Blog
    • Introduction: building & running
    • Documentation
    • Examples
      • From ehuelsmann at common-lisp.net Sun Oct 17 15:22:42 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 17 Oct 2010 11:22:42 -0400 Subject: [armedbear-cvs] r12977 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Oct 17 11:22:41 2010 New Revision: 12977 Log: Unintern symbols with a deleted package as their home package. This is what SBCL does too and fixes current ANSI tests breakage. Modified: trunk/abcl/src/org/armedbear/lisp/Package.java Modified: trunk/abcl/src/org/armedbear/lisp/Package.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Package.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Package.java Sun Oct 17 11:22:41 2010 @@ -49,8 +49,13 @@ private transient LispObject propertyList; + /** Symbols internal to the package. */ private transient final ConcurrentHashMap internalSymbols = new ConcurrentHashMap(16); + /** Symbols exported from the package. + * + * Those symbols in this collection are not contained in the internalSymbols + */ private transient final ConcurrentHashMap externalSymbols = new ConcurrentHashMap(16); @@ -141,12 +146,25 @@ return nicknames; } + private void makeSymbolsUninterned(ConcurrentHashMap symbolMap) { + Symbol sym; + for (Iterator it = symbolMap.values().iterator(); + it.hasNext();) { + sym = it.next(); + if (sym.getPackage() == this) { + sym.setPackage(NIL); + } + } + symbolMap.clear(); + } + public final synchronized boolean delete() { if (name != null) { Packages.deletePackage(this); - internalSymbols.clear(); - externalSymbols.clear(); + + makeSymbolsUninterned(internalSymbols); + makeSymbolsUninterned(externalSymbols); // also clears externalSymbols name = null; lispName = null; From ehuelsmann at common-lisp.net Sun Oct 17 16:45:52 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 17 Oct 2010 12:45:52 -0400 Subject: [armedbear-cvs] r12978 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Oct 17 12:45:49 2010 New Revision: 12978 Log: Fix #98: THREAD type specifier not exported from THREADS package. Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Sun Oct 17 12:45:49 2010 @@ -2912,8 +2912,6 @@ PACKAGE_EXT.addExternalSymbol("MAILBOX"); public static final Symbol MUTEX = PACKAGE_EXT.addExternalSymbol("MUTEX"); - public static final Symbol THREAD = - PACKAGE_EXT.addExternalSymbol("THREAD"); public static final Symbol SUPPRESS_COMPILER_WARNINGS = PACKAGE_EXT.addExternalSymbol("*SUPPRESS-COMPILER-WARNINGS*"); public static final Symbol NEQ = @@ -3098,6 +3096,11 @@ public static final Symbol _INSPECTOR_HOOK_ = PACKAGE_EXT.addExternalSymbol("*INSPECTOR-HOOK*"); - public static final Symbol COMPILER_LET= + public static final Symbol COMPILER_LET = PACKAGE_LISP.addExternalSymbol("COMPILER-LET"); + + // THREADS + public static final Symbol THREAD = + PACKAGE_THREADS.addExternalSymbol("THREAD"); + } From astalla at common-lisp.net Sun Oct 17 19:36:14 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Sun, 17 Oct 2010 15:36:14 -0400 Subject: [armedbear-cvs] r12979 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Sun Oct 17 15:36:13 2010 New Revision: 12979 Log: Do not create class files for local functions that have been inlined Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Oct 17 15:36:13 2010 @@ -918,8 +918,8 @@ (setf (compiland-lambda-expression compiland) lambda-expression) (setf (local-function-definition local-function) (copy-tree definition)) - (setf (local-function-inline-expansion local-function) - (generate-inline-expansion block-name lambda-list body)) + ;(setf (local-function-inline-expansion local-function) + ;(generate-inline-expansion block-name lambda-list body)) (p1-compiland compiland))) (push local-function local-functions))) ((with-saved-compiler-policy @@ -933,7 +933,12 @@ (dolist (special (flet-free-specials block)) (push special *visible-variables*)) (setf (flet-form block) - (list* (car form) local-functions (p1-body (cddr form)))) + (list* (car form) + (remove-if (lambda (fn) + (and (inline-p (local-function-name fn)) + (not (local-function-references-needed-p fn)))) + local-functions) + (p1-body (cddr form)))) block))))) From astalla at common-lisp.net Mon Oct 18 18:03:42 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 18 Oct 2010 14:03:42 -0400 Subject: [armedbear-cvs] r12980 - branches/invokedynamic/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Mon Oct 18 14:03:40 2010 New Revision: 12980 Log: [invokedynamic branch] Save current state of affairs before revolutionizing it. Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Mon Oct 18 14:03:40 2010 @@ -847,7 +847,8 @@ access-flags name descriptor - attributes) + attributes + initial-locals) (defun map-method-name (name) @@ -902,13 +903,15 @@ (defun finalize-method (method class) "Prepares `method' for serialization." (let ((pool (class-file-constants class))) - (setf (method-access-flags method) + (setf (method-initial-locals method) + (compute-initial-method-locals class method) + (method-access-flags method) (map-flags (method-access-flags method)) (method-descriptor method) (constant-index (pool-add-utf8 pool (apply #'descriptor (method-descriptor method)))) (method-name method) (constant-index (pool-add-utf8 pool (method-name method))))) - (finalize-attributes (method-attributes method) nil class)) + (finalize-attributes (method-attributes method) method class)) (defun write-method (method stream) @@ -1001,20 +1004,21 @@ (nconc (mapcar #'exception-start-pc handlers) (mapcar #'exception-end-pc handlers) (mapcar #'exception-handler-pc handlers)) - t))) + t)) + (compute-stack-map-table-p (>= (class-file-major-version class) 50))) (unless (code-max-stack code) (setf (code-max-stack code) (analyze-stack c (mapcar #'exception-handler-pc handlers)))) (unless (code-max-locals code) (setf (code-max-locals code) (analyze-locals code))) - (when (>= (class-file-major-version class) 50) - (code-add-attribute code (compute-stack-map-table class parent))) (multiple-value-bind - (c labels) - (code-bytes c) + (c labels stack-map-table) + (resolve-code c class parent compute-stack-map-table-p) (setf (code-code code) c - (code-labels code) labels))) + (code-labels code) labels) + (when compute-stack-map-table-p + #+todo (code-add-attribute code stack-map-table)))) (setf (code-exception-handlers code) (remove-if #'(lambda (h) @@ -1088,6 +1092,68 @@ :catch-type type) (code-exception-handlers code))) +(defun resolve-code (code class method compute-stack-map-table-p) + "Walks the code, replacing symbolic labels with numeric offsets, and optionally computing the stack map table." + (declare (ignore class)) + (let* ((length 0) + labels ;; alist + stack-map-table + (*basic-block* (when compute-stack-map-table-p + (make-basic-block + :offset 0 + :input-locals + (method-initial-locals method)))) + (root-block *basic-block*) + *basic-blocks*) + (declare (type (unsigned-byte 16) length)) + ;; Pass 1: calculate label offsets and overall length. + (dotimes (i (length code)) + (declare (type (unsigned-byte 16) i)) + (let* ((instruction (aref code i)) + (opcode (instruction-opcode instruction))) + (if (= opcode 202) ; LABEL + (let ((label (car (instruction-args instruction)))) + (set label length) + (setf labels + (acons label length labels)) + (incf length (opcode-size opcode)))))) + ;; Pass 2: replace labels with calculated offsets. + (let ((index 0)) + (declare (type (unsigned-byte 16) index)) + (dotimes (i (length code)) + (declare (type (unsigned-byte 16) i)) + (let ((instruction (aref code i))) + (when (branch-p (instruction-opcode instruction)) + (let* ((label (car (instruction-args instruction))) + (offset (- (the (unsigned-byte 16) + (symbol-value (the symbol label))) + index))) + (setf (instruction-args instruction) (s2 offset)))) + (when compute-stack-map-table-p + (funcall (opcode-effect-function opcode) + instruction index)) + (unless (= (instruction-opcode instruction) 202) ; LABEL + (incf index (opcode-size (instruction-opcode instruction))))))) + ;; Expand instructions into bytes, skipping LABEL pseudo-instructions. + (let ((bytes (make-array length)) + (index 0)) + (declare (type (unsigned-byte 16) index)) + (dotimes (i (length code)) + (declare (type (unsigned-byte 16) i)) + (let ((instruction (aref code i))) + (unless (= (instruction-opcode instruction) 202) ; LABEL + (setf (svref bytes index) (instruction-opcode instruction)) + (incf index) + (dolist (arg (instruction-args instruction)) + (setf (svref bytes index) + (if (constant-p arg) (constant-index arg) arg)) + (incf index))))) + (values bytes labels stack-map-table)))) + +(defun ends-basic-block-p (opcode) + (or (branch-p opcode) + (>= 172 opcode 177))) ;;return variants + (defstruct exception "Exception handler information. @@ -1297,8 +1363,12 @@ "The attribute containing the stack map table, a map from bytecode offsets to frames containing information about the types of locals and values on the operand stack at that offset. This is an attribute of a method." entries) +(defun add-stack-map-frame (stack-map-table instruction-offset locals + stack-items) + (error "TODO!")) + (defun finalize-stack-map-table-attribute (table parent class) - "Prepares the `stack-map-table' attribute for serialization, within method `parent'." + "Prepares the `stack-map-table' attribute for serialization, within method `parent': replaces all virtual types in the stack map frames with variable-info objects." (declare (ignore parent class)) ;;TODO table) @@ -1356,76 +1426,83 @@ (write-u2 (uninitialized-variable-info-offset vti) stream)) (defconst *opcode-effect-table* - (make-array 256 :initial-element #'(lambda (a b) (declare (ignore b)) a))) + (make-array 256 :initial-element #'(lambda (&rest args) (car args)))) (defun opcode-effect-function (opcode) (svref *opcode-effect-table* opcode)) -(defvar *computed-stack* nil "The list of types on the stack calculated from the last emitted instruction, or from the method signature if no instruction has been emitted yet for the current method.") +(defstruct basic-block label offset input-locals input-stack output-locals output-stack successors) + +(defun basic-block-add-successor (basic-block successor) + (push successor (basic-block-successors basic-block))) + +(defvar *basic-block*) +(defvar *basic-blocks* nil "An alist that associates labels with corresponding basic blocks") -(defvar *computed-locals* nil "The list of types of local variables calculated from the last emitted instruction, or from the method signature if no instruction has been emitted yet for the current method.") +(defun label-basic-block (label) + (or (cdr (assoc label *basic-blocks*)) + (setf (assoc label *basic-blocks*) + (make-basic-block :label label + :offset (symbol-value label))))) (defmacro define-opcode-effect (opcode &body body) `(setf (svref *opcode-effect-table* (opcode-number ',opcode)) - #'(lambda (instruction) - (declare (ignorable instruction)) - , at body))) - -(defun update-stack-map-effect! (*computed-stack* *computed-locals* instruction) - (funcall (opcode-effect-function (instruction-opcode instruction)) - instruction) - (setf (instruction-stack-map-locals instruction) *computed-locals*) - (setf (instruction-stack-map-stack instruction) *computed-stack*) - instruction) - -(defun compute-stack-map-table (class method) - (let ((table (make-stack-map-table-attribute)) - (*computed-stack* (compute-initial-method-stack class method)) - (*computed-locals*)) - (finalize-stack-map-table table))) - -(defun finalize-stack-map-table (table) - "Replaces all virtual types in the stack map frames with variable-info objects." - ;;TODO - table) + (if (and (symbolp (car body)) (null (cdr body))) + `(function ,(car body)) + #'(lambda (instruction offset) + (declare (ignorable instruction offset)) + , at body)))) -(defun compute-initial-method-stack (class method) +(defun compute-initial-method-locals (class method) (let (locals) (unless (member :static (method-access-flags method)) (if (string= "" (method-name method)) ;;the method is a constructor. (push :uninitialized-this locals) ;;the method is an instance method. - (push (class-name class) locals))) + (push (class-file-class class) locals))) (dolist (x (cdr (method-descriptor method))) (push x locals)) - locals)) + (nreverse locals))) (defun smf-type->variable-info (type) (case type)) -(defun smf-push (type) - (push type *computed-stack*)) +(defun smf-get (pos) + (or (nth pos (basic-block-output-locals *basic-block*)) + (error "Locals inconsistency: get ~A but locals are ~A" + pos (length (basic-block-output-locals *basic-block*))))) + +(defun smf-set (pos type) + (if (< pos (length (basic-block-output-locals *basic-block*))) + (setf (nth pos (basic-block-output-locals *basic-block*)) type) + (progn + (setf (basic-block-output-locals *basic-block*) + (append (basic-block-output-locals *basic-block*) (list nil))) + (smf-set pos type)))) -(defun smf-push2 (type) - (smf-push type) - (smf-push :top)) +(defun smf-push (type) + (push type (basic-block-output-stack *basic-block*)) + (when (or (eq type :long) (eq type :double)) + (push :top (basic-block-output-stack *basic-block*)))) (defun smf-pop () - (pop *computed-stack*)) + (pop (basic-block-output-stack *basic-block*))) (defun smf-popn (n) (dotimes (i n) - (pop *computed-stack*))) + (pop (basic-block-output-stack *basic-block*)))) (defun smf-element-of (type) - (if (consp type) + (if (and (consp type) (eq (car type) :array-of)) (cdr type) - (error "Not an array stack map type: ~S" type))) + (cons :element-of type))) (defun smf-array-of (type) - (cons :array-of type)) + (if (and (consp type) (eq (car type) :element-of)) + (cdr type) + (cons :array-of type))) (define-opcode-effect aconst_null (smf-push :null)) (define-opcode-effect iconst_m1 (smf-push :int)) @@ -1435,51 +1512,46 @@ (define-opcode-effect iconst_3 (smf-push :int)) (define-opcode-effect iconst_4 (smf-push :int)) (define-opcode-effect iconst_5 (smf-push :int)) -(define-opcode-effect lconst_0 (smf-push2 :long)) -(define-opcode-effect lconst_1 (smf-push2 :long)) +(define-opcode-effect lconst_0 (smf-push :long)) +(define-opcode-effect lconst_1 (smf-push :long)) (define-opcode-effect fconst_0 (smf-push :float)) (define-opcode-effect fconst_1 (smf-push :float)) (define-opcode-effect fconst_2 (smf-push :float)) -(define-opcode-effect dconst_0 (smf-push2 :double)) -(define-opcode-effect dconst_1 (smf-push2 :double)) +(define-opcode-effect dconst_0 (smf-push :double)) +(define-opcode-effect dconst_1 (smf-push :double)) (define-opcode-effect bipush (smf-push :int)) (define-opcode-effect sipush (smf-push :int)) -(define-opcode-effect ldc - (case (constant-type (car (instruction-args instruction))) - (:int (smf-push :int)) - (:long (smf-push2 :long)) - (:float (smf-push :float)) - (:double (smf-push2 :double)) - (t (smf-push (car (instruction-args instruction)))))) +(define-opcode-effect ldc (smf-push (car (instruction-args instruction)))) (define-opcode-effect iload (smf-push :int)) -(define-opcode-effect lload (smf-push2 :long)) +(define-opcode-effect lload (smf-push :long)) (define-opcode-effect fload (smf-push :float)) -(define-opcode-effect dload (smf-push2 :double)) -#|(define-opcode aload 25 2 1) ;;TODO -(define-opcode iload_0 26 1 1) -(define-opcode iload_1 27 1 1) -(define-opcode iload_2 28 1 1) -(define-opcode iload_3 29 1 1) -(define-opcode lload_0 30 1 2) -(define-opcode lload_1 31 1 2) -(define-opcode lload_2 32 1 2) -(define-opcode lload_3 33 1 2) -(define-opcode fload_0 34 1 nil) -(define-opcode fload_1 35 1 nil) -(define-opcode fload_2 36 1 nil) -(define-opcode fload_3 37 1 nil) -(define-opcode dload_0 38 1 nil) -(define-opcode dload_1 39 1 nil) -(define-opcode dload_2 40 1 nil) -(define-opcode dload_3 41 1 nil) -(define-opcode aload_0 42 1 1) -(define-opcode aload_1 43 1 1) -(define-opcode aload_2 44 1 1) -(define-opcode aload_3 45 1 1)|# +(define-opcode-effect dload (smf-push :double)) +(define-opcode-effect aload + (smf-push (smf-get (car (instruction-args instruction))))) +(define-opcode-effect iload_0 (smf-push :int)) +(define-opcode-effect iload_1 (smf-push :int)) +(define-opcode-effect iload_2 (smf-push :int)) +(define-opcode-effect iload_3 (smf-push :int)) +(define-opcode-effect lload_0 (smf-push :long)) +(define-opcode-effect lload_1 (smf-push :long)) +(define-opcode-effect lload_2 (smf-push :long)) +(define-opcode-effect lload_3 (smf-push :long)) +(define-opcode-effect fload_0 (smf-push :float)) +(define-opcode-effect fload_1 (smf-push :float)) +(define-opcode-effect fload_2 (smf-push :float)) +(define-opcode-effect fload_3 (smf-push :float)) +(define-opcode-effect dload_0 (smf-push :double)) +(define-opcode-effect dload_1 (smf-push :double)) +(define-opcode-effect dload_2 (smf-push :double)) +(define-opcode-effect dload_3 (smf-push :double)) +#|(define-opcode-effect aload_0 42 1 1) +(define-opcode-effect aload_1 43 1 1) +(define-opcode-effect aload_2 44 1 1) +(define-opcode-effect aload_3 45 1 1)|# (define-opcode-effect iaload (smf-popn 2) (smf-push :int)) -(define-opcode-effect laload (smf-popn 2) (smf-push2 :long)) +(define-opcode-effect laload (smf-popn 2) (smf-push :long)) (define-opcode-effect faload (smf-popn 2) (smf-push :float)) -(define-opcode-effect daload (smf-popn 2) (smf-push2 :double)) +(define-opcode-effect daload (smf-popn 2) (smf-push :double)) #+nil ;;until there's newarray (define-opcode-effect aaload (progn @@ -1488,12 +1560,35 @@ (define-opcode-effect baload (smf-popn 2) (smf-push :int)) (define-opcode-effect caload (smf-popn 2) (smf-push :int)) (define-opcode-effect saload (smf-popn 2) (smf-push :int)) -#|(define-opcode istore 54 2 -1) -(define-opcode lstore 55 2 -2) -(define-opcode fstore 56 2 nil) -(define-opcode dstore 57 2 nil) -(define-opcode astore 58 2 -1) -(define-opcode istore_0 59 1 -1) + +(defun iaf-store-effect (instruction offset) + (declare (ignore offset)) + (let ((t1 (smf-pop)) + (arg (car (instruction-args instruction)))) + (smf-set arg t1) + (when (> arg 0) + (let ((t2 (smf-get (1- arg)))) + (when (or (eq t2 :long) (eq t2 :double)) + (smf-set (1- arg) :top)))))) + +(defun ld-store-effect (instruction offset) + (declare (ignore offset)) + (smf-pop) + (let ((t1 (smf-pop)) + (arg (car (instruction-args instruction)))) + (smf-set arg t1) + (smf-set (1+ arg) :top) + (when (> arg 0) + (let ((t2 (smf-get (1- arg)))) + (when (or (eq t2 :long) (eq t2 :double)) + (smf-set (1- arg) :top)))))) + +(define-opcode-effect istore iaf-store-effect) +(define-opcode-effect lstore ld-store-effect) +(define-opcode-effect fstore iaf-store-effect) +(define-opcode-effect dstore ld-store-effect) +(define-opcode-effect astore iaf-store-effect) +#|(define-opcode istore_0 59 1 -1) (define-opcode istore_1 60 1 -1) (define-opcode istore_2 61 1 -1) (define-opcode istore_3 62 1 -1) @@ -1509,8 +1604,9 @@ (define-opcode dstore_1 72 1 nil) (define-opcode dstore_2 73 1 nil) (define-opcode dstore_3 74 1 nil) -(define-opcode astore_0 75 1 -1) -(define-opcode astore_1 76 1 -1) +(define-opcode astore_0 75 1 -1)|# +;;TODO +#|(define-opcode astore_1 76 1 -1) (define-opcode astore_2 77 1 -1) (define-opcode astore_3 78 1 -1) (define-opcode iastore 79 1 -3) Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp ============================================================================== --- branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp (original) +++ branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Mon Oct 18 14:03:40 2010 @@ -943,59 +943,12 @@ (print-code code))) code) - - - -(defun code-bytes (code) - (let ((length 0) - labels ;; alist - ) - (declare (type (unsigned-byte 16) length)) - ;; Pass 1: calculate label offsets and overall length. - (dotimes (i (length code)) - (declare (type (unsigned-byte 16) i)) - (let* ((instruction (aref code i)) - (opcode (instruction-opcode instruction))) - (if (= opcode 202) ; LABEL - (let ((label (car (instruction-args instruction)))) - (set label length) - (setf labels - (acons label length labels))) - (incf length (opcode-size opcode))))) - ;; Pass 2: replace labels with calculated offsets. - (let ((index 0)) - (declare (type (unsigned-byte 16) index)) - (dotimes (i (length code)) - (declare (type (unsigned-byte 16) i)) - (let ((instruction (aref code i))) - (when (branch-p (instruction-opcode instruction)) - (let* ((label (car (instruction-args instruction))) - (offset (- (the (unsigned-byte 16) - (symbol-value (the symbol label))) - index))) - (setf (instruction-args instruction) (s2 offset)))) - (unless (= (instruction-opcode instruction) 202) ; LABEL - (incf index (opcode-size (instruction-opcode instruction))))))) - ;; Expand instructions into bytes, skipping LABEL pseudo-instructions. - (let ((bytes (make-array length)) - (index 0)) - (declare (type (unsigned-byte 16) index)) - (dotimes (i (length code)) - (declare (type (unsigned-byte 16) i)) - (let ((instruction (aref code i))) - (unless (= (instruction-opcode instruction) 202) ; LABEL - (setf (svref bytes index) (instruction-opcode instruction)) - (incf index) - (dolist (arg (instruction-args instruction)) - (setf (svref bytes index) - (if (constant-p arg) (constant-index arg) arg)) - (incf index))))) - (values bytes labels)))) - (defun finalize-code (code handler-labels optimize) (setf code (coerce (nreverse code) 'vector)) (when optimize (setf code (optimize-code code handler-labels))) (resolve-instructions (expand-virtual-instructions code))) +;;Opcode effects on locals & stack - for computing the stack map table + (provide '#:opcodes) From ehuelsmann at common-lisp.net Tue Oct 19 08:52:08 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 19 Oct 2010 04:52:08 -0400 Subject: [armedbear-cvs] r12981 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Oct 19 04:52:05 2010 New Revision: 12981 Log: Fix SBCL issue found by building SBCL with ABCL as a host. Note: untabify the changed region, the patch only adds ':length nil' to the WRITE form. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Tue Oct 19 04:52:05 2010 @@ -599,22 +599,23 @@ (write (list 'setq '*source* *compile-file-truename*) :stream out) (%stream-terpri out) - ;; Note: Beyond this point, you can't use DUMP-FORM, - ;; because the list of uninterned symbols has been fixed now. - (when *fasl-uninterned-symbols* - (write (list 'setq '*fasl-uninterned-symbols* - (coerce (mapcar #'car - (nreverse *fasl-uninterned-symbols*)) - 'vector)) - :stream out)) - (%stream-terpri out) - - (when (> *class-number* 0) - (generate-loader-function) - (write (list 'setq '*fasl-loader* - `(sys::make-fasl-class-loader - ,*class-number* - ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out)) + ;; Note: Beyond this point, you can't use DUMP-FORM, + ;; because the list of uninterned symbols has been fixed now. + (when *fasl-uninterned-symbols* + (write (list 'setq '*fasl-uninterned-symbols* + (coerce (mapcar #'car + (nreverse *fasl-uninterned-symbols*)) + 'vector)) + :stream out + :length nil)) + (%stream-terpri out) + + (when (> *class-number* 0) + (generate-loader-function) + (write (list 'setq '*fasl-loader* + `(sys::make-fasl-class-loader + ,*class-number* + ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out)) (%stream-terpri out)) From ehuelsmann at common-lisp.net Tue Oct 19 20:16:12 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 19 Oct 2010 16:16:12 -0400 Subject: [armedbear-cvs] r12982 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Oct 19 16:16:09 2010 New Revision: 12982 Log: Commit DEFINE-METHOD-COMBINATION support as integrated by Mark Evenson; based on testing with SBCL's tests, I've added a single quote. Other than that, it 'mostly works'. By having this on trunk, everybody can help adding tests and fixing issues... (hint, hint!) 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 (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Oct 19 16:16:09 2010 @@ -1,6 +1,7 @@ ;;; clos.lisp ;;; ;;; Copyright (C) 2003-2007 Peter Graves +;;; Copyright (C) 2010 Mark Evenson ;;; $Id$ ;;; ;;; This program is free software; you can redistribute it and/or @@ -30,7 +31,7 @@ ;;; exception statement from your version. ;;; Originally based on Closette. - + ;;; Closette Version 1.0 (February 10, 1991) ;;; ;;; Copyright (c) 1990, 1991 Xerox Corporation. @@ -740,38 +741,55 @@ ,(canonicalize-direct-slots direct-slots) ,@(canonicalize-defclass-options options))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defstruct method-combination - name - operator - identity-with-one-argument - documentation) - - (defun expand-short-defcombin (whole) - (let* ((name (cadr whole)) - (documentation - (getf (cddr whole) :documentation "")) - (identity-with-one-arg - (getf (cddr whole) :identity-with-one-argument nil)) - (operator - (getf (cddr whole) :operator name))) - `(progn - (setf (get ',name 'method-combination-object) - (make-method-combination :name ',name - :operator ',operator - :identity-with-one-argument ',identity-with-one-arg - :documentation ',documentation)) - ',name))) - - (defun expand-long-defcombin (whole) - (declare (ignore whole)) - (error "The long form of DEFINE-METHOD-COMBINATION is not implemented."))) +(defstruct method-combination + name + documentation) + +(defstruct (short-method-combination + (:include method-combination)) + operator + identity-with-one-argument) + +(defstruct (long-method-combination + (:include method-combination)) + lambda-list + method-group-specs + args-lambda-list + generic-function-symbol + function + arguments + declarations + forms) + +(defun expand-long-defcombin (name args) + (destructuring-bind (lambda-list method-groups &rest body) args + `(apply #'define-long-form-method-combination + ',name + ',lambda-list + (list ,@(mapcar #'canonicalize-method-group-spec method-groups)) + ',body))) + +(defun expand-short-defcombin (whole) + (let* ((name (cadr whole)) + (documentation + (getf (cddr whole) :documentation "")) + (identity-with-one-arg + (getf (cddr whole) :identity-with-one-argument nil)) + (operator + (getf (cddr whole) :operator name))) + `(progn + (setf (get ',name 'method-combination-object) + (make-short-method-combination + :name ',name + :operator ',operator + :identity-with-one-argument ',identity-with-one-arg + :documentation ',documentation)) + ',name))) -(defmacro define-method-combination (&whole form &rest args) - (declare (ignore args)) +(defmacro define-method-combination (&whole form name &rest args) (if (and (cddr form) (listp (caddr form))) - (expand-long-defcombin form) + (expand-long-defcombin name args) (expand-short-defcombin form))) (define-method-combination + :identity-with-one-argument t) @@ -784,6 +802,240 @@ (define-method-combination or :identity-with-one-argument t) (define-method-combination progn :identity-with-one-argument t) +;;; +;;; long form of define-method-combination (from Sacla and XCL) +;;; +(defun define-method-combination-type (name &rest initargs) + (setf (get name 'method-combination-object) + (apply 'make-long-method-combination initargs))) + +(defun method-group-p (selecter qualifiers) + ;; selecter::= qualifier-pattern | predicate + (etypecase selecter + (list (or (equal selecter qualifiers) + (let ((last (last selecter))) + (when (eq '* (cdr last)) + (let* ((prefix `(,@(butlast selecter) ,(car last))) + (pos (mismatch prefix qualifiers))) + (or (null pos) (= pos (length prefix)))))))) + ((eql *) t) + (symbol (funcall (symbol-function selecter) qualifiers)))) + +(defun check-variable-name (name) + (flet ((valid-variable-name-p (name) + (and (symbolp name) (not (constantp name))))) + (assert (valid-variable-name-p name)))) + +(defun canonicalize-method-group-spec (spec) + ;; spec ::= (name {qualifier-pattern+ | predicate} [[long-form-option]]) + ;; long-form-option::= :description description | :order order | + ;; :required required-p + ;; a canonicalized-spec is a simple plist. + (let* ((rest spec) + (name (prog2 (check-variable-name (car rest)) + (car rest) + (setq rest (cdr rest)))) + (option-names '(:description :order :required)) + (selecters (let ((end (or (position-if #'(lambda (it) + (member it option-names)) + rest) + (length rest)))) + (prog1 (subseq rest 0 end) + (setq rest (subseq rest end))))) + (description (getf rest :description "")) + (order (getf rest :order :most-specific-first)) + (required-p (getf rest :required))) + `(list :name ',name + :predicate (lambda (qualifiers) + (loop for item in ',selecters + thereis (method-group-p item qualifiers))) + :description ',description + :order ',order + :required ',required-p))) + +(defun extract-required-part (lambda-list) + (flet ((skip (key lambda-list) + (if (eq (first lambda-list) key) + (cddr lambda-list) + lambda-list))) + (ldiff (skip '&environment (skip '&whole lambda-list)) + (member-if #'(lambda (it) (member it lambda-list-keywords)) + lambda-list)))) + +(defun extract-specified-part (key lambda-list) + (case key + ((&eval &whole) + (list (second (member key lambda-list)))) + (t + (let ((here (cdr (member key lambda-list)))) + (ldiff here + (member-if #'(lambda (it) (member it lambda-list-keywords)) + here)))))) + +(defun extract-optional-part (lambda-list) + (extract-specified-part '&optional lambda-list)) + +(defun parse-define-method-combination-arguments-lambda-list (lambda-list) + ;; Define-method-combination Arguments Lambda Lists + ;; http://www.lispworks.com/reference/HyperSpec/Body/03_dj.htm + (let ((required (extract-required-part lambda-list)) + (whole (extract-specified-part '&whole lambda-list)) + (optional (extract-specified-part '&optional lambda-list)) + (rest (extract-specified-part '&rest lambda-list)) + (keys (extract-specified-part '&key lambda-list)) + (aux (extract-specified-part '&aux lambda-list))) + (values (first whole) + required + (mapcar #'(lambda (spec) + (if (consp spec) + `(,(first spec) ,(second spec) ,@(cddr spec)) + `(,spec nil))) + optional) + (first rest) + (mapcar #'(lambda (spec) + (let ((key (if (consp spec) (car spec) spec)) + (rest (when (consp spec) (rest spec)))) + `(,(if (consp key) key `(,(make-keyword key) ,key)) + ,(car rest) + ,@(cdr rest)))) + keys) + (mapcar #'(lambda (spec) + (if (consp spec) + `(,(first spec) ,(second spec)) + `(,spec nil))) + aux)))) + +(defmacro getk (plist key init-form) + "Similar to getf except eval and return INIT-FORM if KEY has no value in PLIST." + (let ((not-exist (gensym)) + (value (gensym))) + `(let ((,value (getf ,plist ,key ,not-exist))) + (if (eq ,not-exist ,value) ,init-form ,value)))) + +(defconstant +gf-args-var+ (make-symbol "GF-ARGS-VAR")) + +(defmacro with-args-lambda-list (args-lambda-list generic-function-symbol + &body forms) + (let ((gf-lambda-list (gensym)) + (nrequired (gensym)) + (noptional (gensym)) + (rest-args (gensym))) + (multiple-value-bind (whole required optional rest keys aux) + (parse-define-method-combination-arguments-lambda-list args-lambda-list) + `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol 'lambda-list)) + (,nrequired (length (extract-required-part ,gf-lambda-list))) + (,noptional (length (extract-optional-part ,gf-lambda-list))) + (,rest-args (subseq ,+gf-args-var+ (+ ,nrequired ,noptional))) + ,@(when whole `((,whole ,+gf-args-var+))) + ,@(loop for var in required and i upfrom 0 + collect `(,var (when (< ,i ,nrequired) + (nth ,i ,+gf-args-var+)))) + ,@(loop for (var init-form) in optional and i upfrom 0 + collect + `(,var (if (< ,i ,noptional) + (nth (+ ,nrequired ,i) ,+gf-args-var+) + ,init-form))) + ,@(when rest `((,rest ,rest-args))) + ,@(loop for ((key var) init-form) in keys and i upfrom 0 + collect `(,var (getk ,rest-args ',key ,init-form))) + ,@(loop for (var init-form) in aux and i upfrom 0 + collect `(,var ,init-form))) + , at forms)))) + +(defmacro with-method-groups (method-group-specs methods-form &body forms) + (flet ((grouping-form (spec methods-var) + (let ((predicate (coerce-to-function (getf spec :predicate))) + (group (gensym)) + (leftovers (gensym)) + (method (gensym))) + `(let ((,group '()) + (,leftovers '())) + (dolist (,method ,methods-var) + (if (funcall ,predicate (method-qualifiers ,method)) + (push ,method ,group) + (push ,method ,leftovers))) + (ecase ,(getf spec :order) + (:most-specific-last ) + (:most-specific-first (setq ,group (nreverse ,group)))) + ,@(when (getf spec :required) + `((when (null ,group) + (error "Method group ~S must not be empty." + ',(getf spec :name))))) + (setq ,methods-var (nreverse ,leftovers)) + ,group)))) + (let ((rest (gensym)) + (method (gensym))) + `(let* ((,rest ,methods-form) + ,@(mapcar #'(lambda (spec) + `(,(getf spec :name) ,(grouping-form spec rest))) + method-group-specs)) + (dolist (,method ,rest) + (invalid-method-error ,method + "Method ~S with qualifiers ~S does not belong to any method group." + ,method (method-qualifiers ,method))) + , at forms)))) + +(defun method-combination-type-lambda + (&key name lambda-list args-lambda-list generic-function-symbol + method-group-specs declarations forms &allow-other-keys) + (let ((methods (gensym))) + `(lambda (,generic-function-symbol ,methods , at lambda-list) + , at declarations + (let ((*message-prefix* ,(format nil "METHOD COMBINATION TYPE ~S: " name))) + (with-method-groups ,method-group-specs + ,methods + ,@(if (null args-lambda-list) + forms + `((with-args-lambda-list ,args-lambda-list + ,generic-function-symbol + , at forms)))))))) + +(defun declarationp (expr) + (and (consp expr) (eq (car expr) 'DECLARE))) + +(defun long-form-method-combination-args (args) + ;; define-method-combination name lambda-list (method-group-specifier*) args + ;; args ::= [(:arguments . args-lambda-list)] + ;; [(:generic-function generic-function-symbol)] + ;; [[declaration* | documentation]] form* + (let ((rest args)) + (labels ((nextp (key) (and (consp (car rest)) (eq key (caar rest)))) + (args-lambda-list () + (when (nextp :arguments) + (prog1 (cdr (car rest)) (setq rest (cdr rest))))) + (generic-function-symbol () + (if (nextp :generic-function) + (prog1 (second (car rest)) (setq rest (cdr rest))) + (gensym))) + (declaration* () + (let ((end (position-if-not #'declarationp rest))) + (when end + (prog1 (subseq rest 0 end) (setq rest (nthcdr end rest)))))) + (documentation? () + (when (stringp (car rest)) + (prog1 (car rest) (setq rest (cdr rest))))) + (form* () rest)) + (let ((declarations '())) + `(:args-lambda-list ,(args-lambda-list) + :generic-function-symbol ,(generic-function-symbol) + :documentation ,(prog2 (setq declarations (declaration*)) + (documentation?)) + :declarations (, at declarations ,@(declaration*)) + :forms ,(form*)))))) + +(defun define-long-form-method-combination (name lambda-list method-group-specs + &rest args) + (let* ((initargs `(:name ,name + :lambda-list ,lambda-list + :method-group-specs ,method-group-specs + ,@(long-form-method-combination-args args))) + (lambda-expression (apply #'method-combination-type-lambda initargs))) + (apply #'define-method-combination-type name + `(, at initargs +;; :function ,(compile nil lambda-expression) + :function ,(coerce-to-function lambda-expression))) + name)) + (defstruct eql-specializer object) @@ -1580,27 +1832,30 @@ (primaries '()) (arounds '()) around - emf-form) - (dolist (m methods) - (let ((qualifiers (method-qualifiers m))) - (cond ((null qualifiers) - (if (eq mc-name 'standard) - (push m primaries) - (error "Method combination type mismatch."))) - ((cdr qualifiers) - (error "Invalid method qualifiers.")) - ((eq (car qualifiers) :around) - (push m arounds)) - ((eq (car qualifiers) mc-name) - (push m primaries)) - ((memq (car qualifiers) '(:before :after))) - (t - (error "Invalid method qualifiers."))))) + emf-form + (long-method-combination-p + (typep (get mc-name 'method-combination-object) 'long-method-combination))) + (unless long-method-combination-p + (dolist (m methods) + (let ((qualifiers (method-qualifiers m))) + (cond ((null qualifiers) + (if (eq mc-name 'standard) + (push m primaries) + (error "Method combination type mismatch."))) + ((cdr qualifiers) + (error "Invalid method qualifiers.")) + ((eq (car qualifiers) :around) + (push m arounds)) + ((eq (car qualifiers) mc-name) + (push m primaries)) + ((memq (car qualifiers) '(:before :after))) + (t + (error "Invalid method qualifiers.")))))) (unless (eq order :most-specific-last) (setf primaries (nreverse primaries))) (setf arounds (nreverse arounds)) (setf around (car arounds)) - (when (null primaries) + (when (and (null primaries) (not long-method-combination-p)) (error "No primary methods for the generic function ~S." gf)) (cond (around @@ -1611,10 +1866,7 @@ #'compute-effective-method-function) gf (remove around methods)))) (setf emf-form -;;; `(lambda (args) -;;; (funcall ,(%method-function around) args ,next-emfun)) - (generate-emf-lambda (%method-function around) next-emfun) - ))) + (generate-emf-lambda (%method-function around) next-emfun)))) ((eq mc-name 'standard) (let* ((next-emfun (compute-primary-emfun (cdr primaries))) (befores (remove-if-not #'before-method-p methods)) @@ -1624,7 +1876,6 @@ (cond ((and (null befores) (null reverse-afters)) (let ((fast-function (%method-fast-function (car primaries)))) - (if fast-function (ecase (length (gf-required-args gf)) (1 @@ -1635,14 +1886,10 @@ #'(lambda (args) (declare (optimize speed)) (funcall fast-function (car args) (cadr args))))) - ;; `(lambda (args) - ;; (declare (optimize speed)) - ;; (funcall ,(%method-function (car primaries)) args ,next-emfun)) (generate-emf-lambda (%method-function (car primaries)) next-emfun)))) (t (let ((method-function (%method-function (car primaries)))) - #'(lambda (args) (declare (optimize speed)) (dolist (before befores) @@ -1651,24 +1898,39 @@ (funcall method-function args next-emfun) (dolist (after reverse-afters) (funcall (%method-function after) args nil)))))))))) - (t - (let ((mc-obj (get mc-name 'method-combination-object))) - (unless mc-obj - (error "Unsupported method combination type ~A." mc-name)) - (let* ((operator (method-combination-operator mc-obj)) - (ioa (method-combination-identity-with-one-argument mc-obj))) - (setf emf-form - (if (and (null (cdr primaries)) - (not (null ioa))) -;; `(lambda (args) -;; (funcall ,(%method-function (car primaries)) args nil)) - (generate-emf-lambda (%method-function (car primaries)) nil) - `(lambda (args) - (,operator ,@(mapcar - (lambda (primary) - `(funcall ,(%method-function primary) args nil)) - primaries))))))))) - (or (ignore-errors (autocompile emf-form)) + (long-method-combination-p + (let* ((mc-obj (get mc-name 'method-combination-object)) + (function (long-method-combination-function mc-obj)) + (arguments (rest (slot-value gf 'method-combination)))) + (assert (typep mc-obj 'long-method-combination)) + (assert function) + (setf emf-form + (let ((result (if arguments + (apply function gf methods arguments) + (funcall function gf methods)))) + `(lambda (args) + (let ((gf-args-var args)) + (macrolet ((call-method (method &optional next-method-list) + `(funcall ,(%method-function method) args nil))) + ,result))))))) + (t + (let ((mc-obj (get mc-name 'method-combination-object))) + (unless (typep mc-obj 'short-method-combination) + (error "Unsupported method combination type ~A." + mc-name)) + (let* ((operator (short-method-combination-operator mc-obj)) + (ioa (short-method-combination-identity-with-one-argument mc-obj))) + (setf emf-form + (if (and (null (cdr primaries)) + (not (null ioa))) + (generate-emf-lambda (%method-function (car primaries)) nil) + `(lambda (args) + (,operator ,@(mapcar + (lambda (primary) + `(funcall ,(%method-function primary) args nil)) + primaries))))))))) + (assert (not (null emf-form))) + (or #+nil (ignore-errors (autocompile emf-form)) (coerce-to-function emf-form)))) (defun generate-emf-lambda (method-function next-emfun) @@ -2455,6 +2717,7 @@ (std-method-more-specific-p method1 method2 required-classes (generic-function-argument-precedence-order gf))) +;;; XXX AMOP has COMPUTE-EFFECTIVE-METHOD (defgeneric compute-effective-method-function (gf methods)) (defmethod compute-effective-method-function ((gf standard-generic-function) methods) (std-compute-effective-method-function gf methods)) From astalla at common-lisp.net Mon Oct 25 22:17:31 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 25 Oct 2010 18:17:31 -0400 Subject: [armedbear-cvs] r12983 - branches/invokedynamic/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Mon Oct 25 18:17:28 2010 New Revision: 12983 Log: [invokedynamic] * instructions simulate their effect on the stack and locals (adapted from ASM, with limitations) * p2 uses with-code-to-method instead of *static-code* to generate and (bugged) * in general, functions that add constants to the pool have been changed to return the constant's struct rather than its index. However I haven't thorougly changed them all, only more or less the ones I needed. * and other changes to keep all the above stuff together. Compilation is still broken: the superclass is set too late. Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/compiler-pass2.lisp branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm.lisp Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/invokedynamic/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/invokedynamic/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Mon Oct 25 18:17:28 2010 @@ -796,150 +796,136 @@ (defun emit-read-from-string (object) (emit-constructor-lambda-list object)) -(defun make-constructor (super lambda-name args) +(defun make-constructor (class) (let* ((*compiler-debug* nil) ;; We don't normally need to see debugging output for constructors. - (method (make-method :constructor :void nil - :flags '(:public))) - (code (method-add-code method)) - req-params-register + (super (class-file-superclass class)) + (lambda-name (abcl-class-file-lambda-name class)) + (args (abcl-class-file-lambda-list class)) + req-params-register opt-params-register key-params-register rest-p keys-p - more-keys-p - (*code* ()) - (*current-code-attribute* code)) - (setf (code-max-locals code) 1) - (unless (eq super +lisp-primitive+) - (multiple-value-bind - (req opt key key-p rest - allow-other-keys-p) - (parse-lambda-list args) - (setf rest-p rest - more-keys-p allow-other-keys-p - keys-p key-p) - (macrolet - ((parameters-to-array ((param params register) &body body) - (let ((count-sym (gensym))) - `(progn - (emit-push-constant-int (length ,params)) - (emit-anewarray +lisp-closure-parameter+) - (astore (setf ,register (code-max-locals code))) - (incf (code-max-locals code)) - (do* ((,count-sym 0 (1+ ,count-sym)) - (,params ,params (cdr ,params)) - (,param (car ,params) (car ,params))) - ((endp ,params)) - (declare (ignorable ,param)) - (aload ,register) - (emit-push-constant-int ,count-sym) - (emit-new +lisp-closure-parameter+) - (emit 'dup) - , at body - (emit 'aastore)))))) - ;; process required args - (parameters-to-array (ignore req req-params-register) - (emit-push-t) ;; we don't need the actual symbol - (emit-invokespecial-init +lisp-closure-parameter+ - (list +lisp-symbol+))) - - (parameters-to-array (param opt opt-params-register) - (emit-push-t) ;; we don't need the actual variable-symbol - (emit-read-from-string (second param)) ;; initform - (if (null (third param)) ;; supplied-p - (emit-push-nil) - (emit-push-t)) ;; we don't need the actual supplied-p symbol - (emit-getstatic +lisp-closure+ "OPTIONAL" :int) - (emit-invokespecial-init +lisp-closure-parameter+ - (list +lisp-symbol+ +lisp-object+ - +lisp-object+ :int))) - - (parameters-to-array (param key key-params-register) - (let ((keyword (fourth param))) - (if (keywordp keyword) - (progn - (emit 'ldc (pool-string (symbol-name keyword))) - (emit-invokestatic +lisp+ "internKeyword" - (list +java-string+) +lisp-symbol+)) - ;; symbol is not really a keyword; yes, that's allowed! - (progn - (emit 'ldc (pool-string (symbol-name keyword))) - (emit 'ldc (pool-string - (package-name (symbol-package keyword)))) - (emit-invokestatic +lisp+ "internInPackage" - (list +java-string+ +java-string+) - +lisp-symbol+)))) - (emit-push-t) ;; we don't need the actual variable-symbol - (emit-read-from-string (second (car key))) - (if (null (third param)) - (emit-push-nil) - (emit-push-t)) ;; we don't need the actual supplied-p symbol - (emit-invokespecial-init +lisp-closure-parameter+ - (list +lisp-symbol+ +lisp-symbol+ - +lisp-object+ +lisp-object+)))))) - (aload 0) ;; this - (cond ((eq super +lisp-primitive+) - (emit-constructor-lambda-name lambda-name) - (emit-constructor-lambda-list args) - (emit-invokespecial-init super (lisp-object-arg-types 2))) - ((equal super +lisp-compiled-closure+) ;;### only needs EQ when SUPER is guaranteed to be CLASS-NAME - (aload req-params-register) - (aload opt-params-register) - (aload key-params-register) - (if keys-p - (emit-push-t) - (emit-push-nil-symbol)) - (if rest-p - (emit-push-t) - (emit-push-nil-symbol)) - (if more-keys-p - (emit-push-t) - (emit-push-nil-symbol)) - (emit-invokespecial-init super - (list +lisp-closure-parameter-array+ - +lisp-closure-parameter-array+ - +lisp-closure-parameter-array+ - +lisp-symbol+ - +lisp-symbol+ +lisp-symbol+))) - (t - (aver nil))) - (setf *code* (append *static-code* *code*)) - (emit 'return) - (setf (code-code code) *code*) - method)) - - -(defun make-static-initializer () - (let* ((*compiler-debug* nil) - ;; We don't normally need to see debugging output for . - (method (make-method :static-initializer - :void nil :flags '(:public :static))) - (code (method-add-code method)) - (*code* ()) - (*current-code-attribute* code)) - (setf (code-max-locals code) 1) - (emit 'ldc (pool-class +lisp-function+)) - (emit 'ldc (pool-string "linkLispFunction")) - (emit-invokestatic +dyn-linkage+ "registerBootstrapMethod" - (list +java-class+ +java-string+) :void) - ;(setf *code* (append *static-code* *code*)) - (emit 'return) - (setf (code-code code) *code*) - method)) + more-keys-p) + (with-code-to-method (class (abcl-class-file-constructor class)) + (setf (code-max-locals *current-code-attribute*) 1) + (unless (eq super +lisp-primitive+) + (multiple-value-bind + (req opt key key-p rest + allow-other-keys-p) + (parse-lambda-list args) + (setf rest-p rest + more-keys-p allow-other-keys-p + keys-p key-p) + (macrolet + ((parameters-to-array ((param params register) &body body) + (let ((count-sym (gensym))) + `(progn + (emit-push-constant-int (length ,params)) + (emit-anewarray +lisp-closure-parameter+) + (astore (setf ,register (code-max-locals *current-code-attribute*))) + (incf (code-max-locals *current-code-attribute*)) + (do* ((,count-sym 0 (1+ ,count-sym)) + (,params ,params (cdr ,params)) + (,param (car ,params) (car ,params))) + ((endp ,params)) + (declare (ignorable ,param)) + (aload ,register) + (emit-push-constant-int ,count-sym) + (emit-new +lisp-closure-parameter+) + (emit 'dup) + , at body + (emit 'aastore)))))) + ;; process required args + (parameters-to-array (ignore req req-params-register) + (emit-push-t) ;; we don't need the actual symbol + (emit-invokespecial-init +lisp-closure-parameter+ + (list +lisp-symbol+))) + + (parameters-to-array (param opt opt-params-register) + (emit-push-t) ;; we don't need the actual variable-symbol + (emit-read-from-string (second param)) ;; initform + (if (null (third param)) ;; supplied-p + (emit-push-nil) + (emit-push-t)) ;; we don't need the actual supplied-p symbol + (emit-getstatic +lisp-closure+ "OPTIONAL" :int) + (emit-invokespecial-init +lisp-closure-parameter+ + (list +lisp-symbol+ +lisp-object+ + +lisp-object+ :int))) + + (parameters-to-array (param key key-params-register) + (let ((keyword (fourth param))) + (if (keywordp keyword) + (progn + (emit 'ldc (pool-string (symbol-name keyword))) + (emit-invokestatic +lisp+ "internKeyword" + (list +java-string+) +lisp-symbol+)) + ;; symbol is not really a keyword; yes, that's allowed! + (progn + (emit 'ldc (pool-string (symbol-name keyword))) + (emit 'ldc (pool-string + (package-name (symbol-package keyword)))) + (emit-invokestatic +lisp+ "internInPackage" + (list +java-string+ +java-string+) + +lisp-symbol+)))) + (emit-push-t) ;; we don't need the actual variable-symbol + (emit-read-from-string (second (car key))) + (if (null (third param)) + (emit-push-nil) + (emit-push-t)) ;; we don't need the actual supplied-p symbol + (emit-invokespecial-init +lisp-closure-parameter+ + (list +lisp-symbol+ +lisp-symbol+ + +lisp-object+ +lisp-object+)))))) + (aload 0) ;; this + (cond ((eq super +lisp-primitive+) + (emit-constructor-lambda-name lambda-name) + (emit-constructor-lambda-list args) + (emit-invokespecial-init super (lisp-object-arg-types 2))) + ((equal super +lisp-compiled-closure+) ;;### only needs EQ when SUPER is guaranteed to be CLASS-NAME + (aload req-params-register) + (aload opt-params-register) + (aload key-params-register) + (if keys-p + (emit-push-t) + (emit-push-nil-symbol)) + (if rest-p + (emit-push-t) + (emit-push-nil-symbol)) + (if more-keys-p + (emit-push-t) + (emit-push-nil-symbol)) + (emit-invokespecial-init super + (list +lisp-closure-parameter-array+ + +lisp-closure-parameter-array+ + +lisp-closure-parameter-array+ + +lisp-symbol+ + +lisp-symbol+ +lisp-symbol+))) + (t + (sys::%format t "MAKE-CONSTRUCTOR doesn't know how to handle superclass ~S~%" super) + (aver nil)))))) + +(defun make-static-initializer (class) + (let ((*compiler-debug* nil)) + ;; We don't normally need to see debugging output for . + (with-code-to-method (class (abcl-class-file-static-initializer class)) + (setf (code-max-locals *current-code-attribute*) 1) + (emit 'ldc (pool-class +lisp-function+)) + (emit 'ldc (pool-string "linkLispFunction")) + (emit-invokestatic +dyn-linkage+ "registerBootstrapMethod" + (list +java-class+ +java-string+) :void) + (emit 'return)))) (defvar *source-line-number* nil) - (defun finish-class (class stream) "Finalizes the `class' and writes the result to `stream'. The compiler calls this function to indicate it doesn't want to extend the class any further." - (class-add-method class (make-constructor (class-file-superclass class) - (abcl-class-file-lambda-name class) - (abcl-class-file-lambda-list class))) - (class-add-method class (make-static-initializer)) + (with-code-to-method (class (abcl-class-file-constructor class)) + (emit 'return)) + (make-static-initializer class) (finalize-class-file class) (write-class-file class stream)) @@ -1106,8 +1092,8 @@ the value of the object can be loaded. Objects may be coalesced based on the equality indicator in the `serialization-table'. -Code to restore the serialized object is inserted into `*code' or -`*static-code*' if `*declare-inline*' is non-nil. +Code to restore the serialized object is inserted into the current method or +the constructor if `*declare-inline*' is non-nil. " ;; TODO: rewrite to become EMIT-LOAD-EXTERNALIZED-OBJECT which ;; - instead of returning the name of the field - returns the type @@ -1137,23 +1123,23 @@ (cond ((not *file-compilation*) - (let ((*code* *static-code*)) + (with-code-to-method + (*class-file* (abcl-class-file-constructor *class-file*)) (remember field-name object) (emit 'ldc (pool-string field-name)) (emit-invokestatic +lisp+ "recall" (list +java-string+) +lisp-object+) (when (not (eq field-type +lisp-object+)) (emit-checkcast field-type)) - (emit-putstatic *this-class* field-name field-type) - (setf *static-code* *code*))) + (emit-putstatic *this-class* field-name field-type))) (*declare-inline* (funcall dispatch-fn object) (emit-putstatic *this-class* field-name field-type)) (t - (let ((*code* *static-code*)) + (with-code-to-method + (*class-file* (abcl-class-file-constructor *class-file*)) (funcall dispatch-fn object) - (emit-putstatic *this-class* field-name field-type) - (setf *static-code* *code*)))) + (emit-putstatic *this-class* field-name field-type)))) (emit-getstatic *this-class* field-name field-type) (when cast @@ -1183,30 +1169,26 @@ (declare-object-as-string symbol) (declare-object symbol)) class *this-class*)) - (let (saved-code) - (let ((*code* (if *declare-inline* *code* *static-code*))) - (if (eq class *this-class*) - (progn ;; generated by the DECLARE-OBJECT*'s above - (emit-getstatic class name +lisp-object+) - (emit-checkcast +lisp-symbol+)) - (emit-getstatic class name +lisp-symbol+)) - (emit-invokevirtual +lisp-symbol+ - (if setf - "getSymbolSetfFunctionOrDie" - "getSymbolFunctionOrDie") - nil +lisp-object+) - ;; make sure we're not cacheing a proxied function - ;; (AutoloadedFunctionProxy) by allowing it to resolve itself - (emit-invokevirtual +lisp-object+ - "resolve" nil +lisp-object+) - (emit-putstatic *this-class* f +lisp-object+) - (if *declare-inline* - (setf saved-code *code*) - (setf *static-code* *code*)) - (setf (gethash symbol ht) f)) - (when *declare-inline* - (setf *code* saved-code)) - f)))) + (with-code-to-method (*class-file* + (if *declare-inline* *method* + (abcl-class-file-constructor *class-file*))) + (if (eq class *this-class*) + (progn ;; generated by the DECLARE-OBJECT*'s above + (emit-getstatic class name +lisp-object+) + (emit-checkcast +lisp-symbol+)) + (emit-getstatic class name +lisp-symbol+)) + (emit-invokevirtual +lisp-symbol+ + (if setf + "getSymbolSetfFunctionOrDie" + "getSymbolFunctionOrDie") + nil +lisp-object+) + ;; make sure we're not cacheing a proxied function + ;; (AutoloadedFunctionProxy) by allowing it to resolve itself + (emit-invokevirtual +lisp-object+ + "resolve" nil +lisp-object+) + (emit-putstatic *this-class* f +lisp-object+)) + (setf (gethash symbol ht) f) + f))) (defknown declare-setf-function (name) string) (defun declare-setf-function (name) @@ -1218,17 +1200,17 @@ (declare-with-hashtable local-function *declared-functions* ht g (setf g (symbol-name (gensym "LFUN"))) - (let* ((class-name (abcl-class-file-class-name - (local-function-class-file local-function))) - (*code* *static-code*)) + (let ((class-name (abcl-class-file-class-name + (local-function-class-file local-function)))) + (with-code-to-method + (*class-file* (abcl-class-file-constructor *class-file*)) ;; fixme *declare-inline* - (declare-field g +lisp-object+) - (emit-new class-name) - (emit 'dup) - (emit-invokespecial-init class-name '()) - (emit-putstatic *this-class* g +lisp-object+) - (setf *static-code* *code*) - (setf (gethash local-function ht) g)))) + (declare-field g +lisp-object+) + (emit-new class-name) + (emit 'dup) + (emit-invokespecial-init class-name '()) + (emit-putstatic *this-class* g +lisp-object+) + (setf (gethash local-function ht) g))))) (defknown declare-object-as-string (t) string) @@ -1241,44 +1223,38 @@ ;; The solution is to rewrite externalize-object to ;; EMIT-LOAD-EXTERNALIZED-OBJECT, which serializes *and* ;; emits the right loading code (not just de-serialization anymore) - (let (saved-code - (g (symbol-name (gensym "OBJSTR")))) - (let* ((s (with-output-to-string (stream) (dump-form obj stream))) - (*code* (if *declare-inline* *code* *static-code*))) - ;; strings may contain evaluated bits which may depend on - ;; previous statements - (declare-field g +lisp-object+) - (emit 'ldc (pool-string s)) - (emit-invokestatic +lisp+ "readObjectFromString" - (list +java-string+) +lisp-object+) - (emit-putstatic *this-class* g +lisp-object+) - (if *declare-inline* - (setf saved-code *code*) - (setf *static-code* *code*))) - (when *declare-inline* - (setf *code* saved-code)) - g)) + (let ((g (symbol-name (gensym "OBJSTR"))) + (s (with-output-to-string (stream) (dump-form obj stream)))) + (with-code-to-method + (*class-file* + (if *declare-inline* *method* + (abcl-class-file-constructor *class-file*))) + ;; strings may contain evaluated bits which may depend on + ;; previous statements + (declare-field g +lisp-object+) + (emit 'ldc (pool-string s)) + (emit-invokestatic +lisp+ "readObjectFromString" + (list +java-string+) +lisp-object+) + (emit-putstatic *this-class* g +lisp-object+)) + g)) (defun declare-load-time-value (obj) (let ((g (symbol-name (gensym "LTV"))) - saved-code) - (let* ((s (with-output-to-string (stream) (dump-form obj stream))) - (*code* (if *declare-inline* *code* *static-code*))) - ;; The readObjectFromString call may require evaluation of - ;; lisp code in the string (think #.() syntax), of which the outcome - ;; may depend on something which was declared inline - (declare-field g +lisp-object+) - (emit 'ldc (pool-string s)) - (emit-invokestatic +lisp+ "readObjectFromString" - (list +java-string+) +lisp-object+) - (emit-invokestatic +lisp+ "loadTimeValue" - (lisp-object-arg-types 1) +lisp-object+) - (emit-putstatic *this-class* g +lisp-object+) - (if *declare-inline* - (setf saved-code *code*) - (setf *static-code* *code*))) - (when *declare-inline* - (setf *code* saved-code)) + (s (with-output-to-string (stream) (dump-form obj stream)))) + (with-code-to-method + (*class-file* + (if *declare-inline* *method* + (abcl-class-file-constructor *class-file*))) + ;; The readObjectFromString call may require evaluation of + ;; lisp code in the string (think #.() syntax), of which the outcome + ;; may depend on something which was declared inline + (declare-field g +lisp-object+) + (emit 'ldc (pool-string s)) + (emit-invokestatic +lisp+ "readObjectFromString" + (list +java-string+) +lisp-object+) + (emit-invokestatic +lisp+ "loadTimeValue" + (lisp-object-arg-types 1) +lisp-object+) + (emit-putstatic *this-class* g +lisp-object+)) g)) (declaim (ftype (function (t) string) declare-object)) @@ -1290,14 +1266,14 @@ (let ((g (symbol-name (gensym "OBJ")))) ;; fixme *declare-inline*? (remember g obj) - (let* ((*code* *static-code*)) + (with-code-to-method + (*class-file* (abcl-class-file-constructor *class-file*)) (declare-field g +lisp-object+) (emit 'ldc (pool-string g)) (emit-invokestatic +lisp+ "recall" (list +java-string+) +lisp-object+) - (emit-putstatic *this-class* g +lisp-object+) - (setf *static-code* *code*) - g))) + (emit-putstatic *this-class* g +lisp-object+)) + g)) (defknown compile-constant (t t t) t) (defun compile-constant (form target representation) @@ -3823,6 +3799,7 @@ :element-type '(unsigned-byte 8) :if-exists :supersede))) (with-class-file class-file + (make-constructor class-file) (let ((*current-compiland* compiland)) (with-saved-compiler-policy (p2-compiland compiland) @@ -6875,6 +6852,8 @@ (method (make-method "execute" +lisp-object+ arg-types :flags '(:final :public))) (code (method-add-code method)) + (*code-locals* (code-computed-locals code)) ;;TODO in this and other cases, use with-code-to-method + (*code-stack* (code-computed-stack code)) (*current-code-attribute* code) (*code* ()) (*register* 1) ;; register 0: "this" pointer @@ -6883,7 +6862,8 @@ (*thread* nil) (*initialize-thread-var* nil) - (label-START (gensym))) + (label-START (gensym)) + prologue) (class-add-method class-file method) (when (fixnump *source-line-number*) @@ -6896,6 +6876,36 @@ (dolist (var (compiland-free-specials compiland)) (push var *visible-variables*)) + ;;Prologue + (let ((arity (compiland-arity compiland))) + (when arity + (generate-arg-count-check arity))) + + (when *hairy-arglist-p* + (aload 0) ; this + (aver (not (null (compiland-argument-register compiland)))) + (aload (compiland-argument-register compiland)) ; arg vector + (cond ((or (memq '&OPTIONAL args) (memq '&KEY args)) + (ensure-thread-var-initialized) + (maybe-initialize-thread-var) + (emit-push-current-thread) + (emit-invokevirtual *this-class* "processArgs" + (list +lisp-object-array+ +lisp-thread+) + +lisp-object-array+)) + (t + (emit-invokevirtual *this-class* "fastProcessArgs" + (list +lisp-object-array+) + +lisp-object-array+))) + (astore (compiland-argument-register compiland))) + + (unless (and *hairy-arglist-p* + (or (memq '&OPTIONAL args) (memq '&KEY args))) + (maybe-initialize-thread-var)) + + (setf prologue *code* + *code* ()) + ;;;; + (when *using-arg-array* (setf (compiland-argument-register compiland) (allocate-register))) @@ -7039,7 +7049,7 @@ (check-for-unused-variables (compiland-arg-vars compiland)) ;; Go back and fill in prologue. - (let ((code *code*)) + #+nil (let ((code *code*)) (setf *code* ()) (let ((arity (compiland-arity compiland))) (when arity @@ -7066,6 +7076,8 @@ (or (memq '&OPTIONAL args) (memq '&KEY args))) (maybe-initialize-thread-var)) (setf *code* (nconc code *code*))) + + (setf *code* (nconc prologue *code*)) (setf (abcl-class-file-superclass class-file) (if (or *hairy-arglist-p* @@ -7076,8 +7088,6 @@ (setf (abcl-class-file-lambda-list class-file) args) (setf (code-max-locals code) *registers-allocated*) (setf (code-code code) *code*)) - - t) (defun p2-with-inline-code (form target representation) @@ -7122,6 +7132,7 @@ ;; Pass 2. (with-class-file (compiland-class-file compiland) + (make-constructor *class-file*) (with-saved-compiler-policy (p2-compiland compiland) ;; (finalize-class-file (compiland-class-file compiland)) Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Mon Oct 25 18:17:28 2010 @@ -291,27 +291,27 @@ (defstruct (constant-member-ref (:constructor %make-constant-member-ref - (tag index class-index name/type-index)) + (tag index class name/type)) (:include constant)) "Structure holding information on a member reference type item (a field, method or interface method reference) in the constant pool." - class-index - name/type-index) + class + name/type) (declaim (inline make-constant-field-ref make-constant-method-ref make-constant-interface-method-ref)) -(defun make-constant-field-ref (index class-index name/type-index) +(defun make-constant-field-ref (index class name/type) "Creates a `constant-member-ref' instance containing a field reference." - (%make-constant-member-ref 9 index class-index name/type-index)) + (%make-constant-member-ref 9 index class name/type)) -(defun make-constant-method-ref (index class-index name/type-index) +(defun make-constant-method-ref (index class name/type) "Creates a `constant-member-ref' instance containing a method reference." - (%make-constant-member-ref 10 index class-index name/type-index)) + (%make-constant-member-ref 10 index class name/type)) -(defun make-constant-interface-method-ref (index class-index name/type-index) +(defun make-constant-interface-method-ref (index class name/type) "Creates a `constant-member-ref' instance containing an interface-method reference." - (%make-constant-member-ref 11 index class-index name/type-index)) + (%make-constant-member-ref 11 index class name/type)) (defstruct (constant-string (:constructor make-constant-string (index value-index)) @@ -354,14 +354,14 @@ (defstruct (constant-name/type (:constructor make-constant-name/type (index - name-index - descriptor-index)) + name + descriptor)) (:include constant (tag 12))) "Structure holding information on a 'name-and-type' type item in the constant pool; this type of element is used by 'member-ref' type items." - name-index - descriptor-index) + name + descriptor) (defstruct (constant-utf8 (:constructor make-constant-utf8 (index value)) (:include constant @@ -395,8 +395,8 @@ `type' is a field-type (see `internal-field-type')" (let ((entry (gethash (acons name type class) (pool-entries pool)))) (unless entry - (let ((c (constant-index (pool-add-class pool class))) - (n/t (constant-index (pool-add-name/type pool name type)))) + (let ((c (pool-add-class pool class)) + (n/t (pool-add-name/type pool name type))) (setf entry (make-constant-field-ref (incf (pool-index pool)) c n/t) (gethash (acons name type class) (pool-entries pool)) entry)) (push entry (pool-entries-list pool))) @@ -410,8 +410,8 @@ and return type. `class' is an instance of `class-name'." (let ((entry (gethash (acons name type class) (pool-entries pool)))) (unless entry - (let ((c (constant-index (pool-add-class pool class))) - (n/t (constant-index (pool-add-name/type pool name type)))) + (let ((c (pool-add-class pool class)) + (n/t (pool-add-name/type pool name type))) (setf entry (make-constant-method-ref (incf (pool-index pool)) c n/t) (gethash (acons name type class) (pool-entries pool)) entry)) (push entry (pool-entries-list pool))) @@ -424,8 +424,8 @@ See `pool-add-method-ref' for remarks." (let ((entry (gethash (acons name type class) (pool-entries pool)))) (unless entry - (let ((c (constant-index (pool-add-class pool class))) - (n/t (constant-index (pool-add-name/type pool name type)))) + (let ((c (pool-add-class pool class)) + (n/t (pool-add-name/type pool name type))) (setf entry (make-constant-interface-method-ref (incf (pool-index pool)) c n/t) (gethash (acons name type class) (pool-entries pool)) entry)) @@ -491,8 +491,8 @@ (apply #'descriptor type) (internal-field-ref type)))) (unless entry - (let ((n (constant-index (pool-add-utf8 pool name))) - (i-t (constant-index (pool-add-utf8 pool internal-type)))) + (let ((n (pool-add-utf8 pool name)) + (i-t (pool-add-utf8 pool internal-type))) (setf entry (make-constant-name/type (incf (pool-index pool)) n i-t) (gethash (cons name type) (pool-entries pool)) entry)) (push entry (pool-entries-list pool))) @@ -733,11 +733,11 @@ (write-u4 (logand (constant-double/long-value entry) #xFFFFffff) stream)) ((9 10 11) ; fieldref methodref InterfaceMethodref - (write-u2 (constant-member-ref-class-index entry) stream) - (write-u2 (constant-member-ref-name/type-index entry) stream)) + (write-u2 (constant-index (constant-member-ref-class entry)) stream) + (write-u2 (constant-index (constant-member-ref-name/type entry)) stream)) (12 ; nameAndType - (write-u2 (constant-name/type-name-index entry) stream) - (write-u2 (constant-name/type-descriptor-index entry) stream)) + (write-u2 (constant-index (constant-name/type-name entry)) stream) + (write-u2 (constant-index (constant-name/type-descriptor entry)) stream)) (7 ; class (write-u2 (constant-class-name-index entry) stream)) (8 ; string @@ -757,10 +757,10 @@ ((5 6) (sys::%format t "d/l: ~a~%" (constant-double/long-value entry))) ((9 10 11) (sys::%format t "ref: ~a,~a~%" (constant-member-ref-class-index entry) - (constant-member-ref-name/type-index entry))) + (constant-member-ref-name/type entry))) (12 (sys::%format t "n/t: ~a,~a~%" - (constant-name/type-name-index entry) - (constant-name/type-descriptor-index entry))) + (constant-name/type-name entry) + (constant-name/type-descriptor entry))) (7 (sys::%format t "cls: ~a~%" (constant-class-name-index entry))) (8 (sys::%format t "str: ~a~%" (constant-string-value-index entry)))))) @@ -847,8 +847,7 @@ access-flags name descriptor - attributes - initial-locals) + attributes) (defun map-method-name (name) @@ -882,9 +881,7 @@ returning the created attribute." (method-add-attribute method - (make-code-attribute (+ (length (cdr (method-descriptor method))) - (if (member :static (method-access-flags method)) - 0 1))))) ;; 1 == implicit 'this' + (make-code-attribute (compute-initial-method-locals method)))) (defun method-ensure-code (method) "Ensures the existence of a 'Code' attribute for the method, @@ -903,9 +900,7 @@ (defun finalize-method (method class) "Prepares `method' for serialization." (let ((pool (class-file-constants class))) - (setf (method-initial-locals method) - (compute-initial-method-locals class method) - (method-access-flags method) + (setf (method-access-flags method) (map-flags (method-access-flags method)) (method-descriptor method) (constant-index (pool-add-utf8 pool (apply #'descriptor (method-descriptor method)))) @@ -979,9 +974,10 @@ ;; labels contains offsets into the code array after it's finalized labels ;; an alist - ;; these two are used for handling nested WITH-CODE-TO-METHOD blocks + ;; these are used for handling nested WITH-CODE-TO-METHOD blocks (current-local 0) - stack-map-frames) + computed-locals + computed-stack) @@ -1065,10 +1061,11 @@ (write-attributes (code-attributes code) stream)) -(defun make-code-attribute (arg-count) +(defun make-code-attribute (locals) "Creates an empty 'Code' attribute for a method which takes `arg-count` parameters, including the implicit `this` parameter." - (%make-code-attribute :max-locals arg-count)) + (%make-code-attribute :max-locals (length locals) + :computed-locals locals)) (defun code-add-attribute (code attribute) "Adds `attribute' to `code', returning `attribute'." @@ -1097,26 +1094,28 @@ (declare (ignore class)) (let* ((length 0) labels ;; alist - stack-map-table - (*basic-block* (when compute-stack-map-table-p + stack-map-table) +#|| (*basic-block* (when compute-stack-map-table-p (make-basic-block :offset 0 :input-locals (method-initial-locals method)))) (root-block *basic-block*) - *basic-blocks*) + *basic-blocks*)||# + compute-stack-map-table-p :todo (declare (type (unsigned-byte 16) length)) ;; Pass 1: calculate label offsets and overall length. (dotimes (i (length code)) (declare (type (unsigned-byte 16) i)) (let* ((instruction (aref code i)) (opcode (instruction-opcode instruction))) + (setf (instruction-offset instruction) length) (if (= opcode 202) ; LABEL (let ((label (car (instruction-args instruction)))) (set label length) (setf labels - (acons label length labels)) - (incf length (opcode-size opcode)))))) + (acons label length labels))) + (incf length (opcode-size opcode))))) ;; Pass 2: replace labels with calculated offsets. (let ((index 0)) (declare (type (unsigned-byte 16) index)) @@ -1129,9 +1128,6 @@ (symbol-value (the symbol label))) index))) (setf (instruction-args instruction) (s2 offset)))) - (when compute-stack-map-table-p - (funcall (opcode-effect-function opcode) - instruction index)) (unless (= (instruction-opcode instruction) 202) ; LABEL (incf index (opcode-size (instruction-opcode instruction))))))) ;; Expand instructions into bytes, skipping LABEL pseudo-instructions. @@ -1214,6 +1210,7 @@ to which it has been attached has been superseded.") (defvar *current-code-attribute* nil) +(defvar *method* nil) (defun save-code-specials (code) (setf (code-code code) *code* @@ -1233,16 +1230,21 @@ (when *current-code-attribute* (save-code-specials *current-code-attribute*)) (let* ((,m ,method) + (*method* ,m) (,c (method-ensure-code ,method)) (*pool* (class-file-constants ,class-file)) (*code* (code-code ,c)) + (*code-locals* (code-computed-locals ,c)) + (*code-stack* (code-computed-stack ,c)) (*registers-allocated* (code-max-locals ,c)) (*register* (code-current-local ,c)) (*current-code-attribute* ,c)) , at body (setf (code-code ,c) *code* (code-current-local ,c) *register* - (code-max-locals ,c) *registers-allocated*)) + (code-max-locals ,c) *registers-allocated* + (code-computed-locals ,c) *code-locals* + (code-computed-stack ,c) *code-stack*)) (when *current-code-attribute* (restore-code-specials *current-code-attribute*))))) @@ -1425,318 +1427,20 @@ (write-u1 (verification-type-info-tag vti) stream) (write-u2 (uninitialized-variable-info-offset vti) stream)) -(defconst *opcode-effect-table* - (make-array 256 :initial-element #'(lambda (&rest args) (car args)))) - -(defun opcode-effect-function (opcode) - (svref *opcode-effect-table* opcode)) - -(defstruct basic-block label offset input-locals input-stack output-locals output-stack successors) - -(defun basic-block-add-successor (basic-block successor) - (push successor (basic-block-successors basic-block))) - -(defvar *basic-block*) -(defvar *basic-blocks* nil "An alist that associates labels with corresponding basic blocks") - -(defun label-basic-block (label) - (or (cdr (assoc label *basic-blocks*)) - (setf (assoc label *basic-blocks*) - (make-basic-block :label label - :offset (symbol-value label))))) - -(defmacro define-opcode-effect (opcode &body body) - `(setf (svref *opcode-effect-table* - (opcode-number ',opcode)) - (if (and (symbolp (car body)) (null (cdr body))) - `(function ,(car body)) - #'(lambda (instruction offset) - (declare (ignorable instruction offset)) - , at body)))) - -(defun compute-initial-method-locals (class method) +(defun compute-initial-method-locals (method) (let (locals) (unless (member :static (method-access-flags method)) (if (string= "" (method-name method)) ;;the method is a constructor. (push :uninitialized-this locals) ;;the method is an instance method. - (push (class-file-class class) locals))) + (push :this locals))) (dolist (x (cdr (method-descriptor method))) (push x locals)) (nreverse locals))) (defun smf-type->variable-info (type) - (case type)) - -(defun smf-get (pos) - (or (nth pos (basic-block-output-locals *basic-block*)) - (error "Locals inconsistency: get ~A but locals are ~A" - pos (length (basic-block-output-locals *basic-block*))))) - -(defun smf-set (pos type) - (if (< pos (length (basic-block-output-locals *basic-block*))) - (setf (nth pos (basic-block-output-locals *basic-block*)) type) - (progn - (setf (basic-block-output-locals *basic-block*) - (append (basic-block-output-locals *basic-block*) (list nil))) - (smf-set pos type)))) - -(defun smf-push (type) - (push type (basic-block-output-stack *basic-block*)) - (when (or (eq type :long) (eq type :double)) - (push :top (basic-block-output-stack *basic-block*)))) - -(defun smf-pop () - (pop (basic-block-output-stack *basic-block*))) - -(defun smf-popn (n) - (dotimes (i n) - (pop (basic-block-output-stack *basic-block*)))) - -(defun smf-element-of (type) - (if (and (consp type) (eq (car type) :array-of)) - (cdr type) - (cons :element-of type))) - -(defun smf-array-of (type) - (if (and (consp type) (eq (car type) :element-of)) - (cdr type) - (cons :array-of type))) - -(define-opcode-effect aconst_null (smf-push :null)) -(define-opcode-effect iconst_m1 (smf-push :int)) -(define-opcode-effect iconst_0 (smf-push :int)) -(define-opcode-effect iconst_1 (smf-push :int)) -(define-opcode-effect iconst_2 (smf-push :int)) -(define-opcode-effect iconst_3 (smf-push :int)) -(define-opcode-effect iconst_4 (smf-push :int)) -(define-opcode-effect iconst_5 (smf-push :int)) -(define-opcode-effect lconst_0 (smf-push :long)) -(define-opcode-effect lconst_1 (smf-push :long)) -(define-opcode-effect fconst_0 (smf-push :float)) -(define-opcode-effect fconst_1 (smf-push :float)) -(define-opcode-effect fconst_2 (smf-push :float)) -(define-opcode-effect dconst_0 (smf-push :double)) -(define-opcode-effect dconst_1 (smf-push :double)) -(define-opcode-effect bipush (smf-push :int)) -(define-opcode-effect sipush (smf-push :int)) -(define-opcode-effect ldc (smf-push (car (instruction-args instruction)))) -(define-opcode-effect iload (smf-push :int)) -(define-opcode-effect lload (smf-push :long)) -(define-opcode-effect fload (smf-push :float)) -(define-opcode-effect dload (smf-push :double)) -(define-opcode-effect aload - (smf-push (smf-get (car (instruction-args instruction))))) -(define-opcode-effect iload_0 (smf-push :int)) -(define-opcode-effect iload_1 (smf-push :int)) -(define-opcode-effect iload_2 (smf-push :int)) -(define-opcode-effect iload_3 (smf-push :int)) -(define-opcode-effect lload_0 (smf-push :long)) -(define-opcode-effect lload_1 (smf-push :long)) -(define-opcode-effect lload_2 (smf-push :long)) -(define-opcode-effect lload_3 (smf-push :long)) -(define-opcode-effect fload_0 (smf-push :float)) -(define-opcode-effect fload_1 (smf-push :float)) -(define-opcode-effect fload_2 (smf-push :float)) -(define-opcode-effect fload_3 (smf-push :float)) -(define-opcode-effect dload_0 (smf-push :double)) -(define-opcode-effect dload_1 (smf-push :double)) -(define-opcode-effect dload_2 (smf-push :double)) -(define-opcode-effect dload_3 (smf-push :double)) -#|(define-opcode-effect aload_0 42 1 1) -(define-opcode-effect aload_1 43 1 1) -(define-opcode-effect aload_2 44 1 1) -(define-opcode-effect aload_3 45 1 1)|# -(define-opcode-effect iaload (smf-popn 2) (smf-push :int)) -(define-opcode-effect laload (smf-popn 2) (smf-push :long)) -(define-opcode-effect faload (smf-popn 2) (smf-push :float)) -(define-opcode-effect daload (smf-popn 2) (smf-push :double)) -#+nil ;;until there's newarray -(define-opcode-effect aaload - (progn - (smf-pop) - (smf-push (smf-element-of (smf-pop))))) -(define-opcode-effect baload (smf-popn 2) (smf-push :int)) -(define-opcode-effect caload (smf-popn 2) (smf-push :int)) -(define-opcode-effect saload (smf-popn 2) (smf-push :int)) - -(defun iaf-store-effect (instruction offset) - (declare (ignore offset)) - (let ((t1 (smf-pop)) - (arg (car (instruction-args instruction)))) - (smf-set arg t1) - (when (> arg 0) - (let ((t2 (smf-get (1- arg)))) - (when (or (eq t2 :long) (eq t2 :double)) - (smf-set (1- arg) :top)))))) - -(defun ld-store-effect (instruction offset) - (declare (ignore offset)) - (smf-pop) - (let ((t1 (smf-pop)) - (arg (car (instruction-args instruction)))) - (smf-set arg t1) - (smf-set (1+ arg) :top) - (when (> arg 0) - (let ((t2 (smf-get (1- arg)))) - (when (or (eq t2 :long) (eq t2 :double)) - (smf-set (1- arg) :top)))))) - -(define-opcode-effect istore iaf-store-effect) -(define-opcode-effect lstore ld-store-effect) -(define-opcode-effect fstore iaf-store-effect) -(define-opcode-effect dstore ld-store-effect) -(define-opcode-effect astore iaf-store-effect) -#|(define-opcode istore_0 59 1 -1) -(define-opcode istore_1 60 1 -1) -(define-opcode istore_2 61 1 -1) -(define-opcode istore_3 62 1 -1) -(define-opcode lstore_0 63 1 -2) -(define-opcode lstore_1 64 1 -2) -(define-opcode lstore_2 65 1 -2) -(define-opcode lstore_3 66 1 -2) -(define-opcode fstore_0 67 1 nil) -(define-opcode fstore_1 68 1 nil) -(define-opcode fstore_2 69 1 nil) -(define-opcode fstore_3 70 1 nil) -(define-opcode dstore_0 71 1 nil) -(define-opcode dstore_1 72 1 nil) -(define-opcode dstore_2 73 1 nil) -(define-opcode dstore_3 74 1 nil) -(define-opcode astore_0 75 1 -1)|# -;;TODO -#|(define-opcode astore_1 76 1 -1) -(define-opcode astore_2 77 1 -1) -(define-opcode astore_3 78 1 -1) -(define-opcode iastore 79 1 -3) -(define-opcode lastore 80 1 -4) -(define-opcode fastore 81 1 -3) -(define-opcode dastore 82 1 -4) -(define-opcode aastore 83 1 -3) -(define-opcode bastore 84 1 nil) -(define-opcode castore 85 1 nil) -(define-opcode sastore 86 1 nil) -(define-opcode pop 87 1 -1) -(define-opcode pop2 88 1 -2) -(define-opcode dup 89 1 1) -(define-opcode dup_x1 90 1 1) -(define-opcode dup_x2 91 1 1) -(define-opcode dup2 92 1 2) -(define-opcode dup2_x1 93 1 2) -(define-opcode dup2_x2 94 1 2) -(define-opcode swap 95 1 0) -(define-opcode iadd 96 1 -1) -(define-opcode ladd 97 1 -2) -(define-opcode fadd 98 1 -1) -(define-opcode dadd 99 1 -2) -(define-opcode isub 100 1 -1) -(define-opcode lsub 101 1 -2) -(define-opcode fsub 102 1 -1) -(define-opcode dsub 103 1 -2) -(define-opcode imul 104 1 -1) -(define-opcode lmul 105 1 -2) -(define-opcode fmul 106 1 -1) -(define-opcode dmul 107 1 -2) -(define-opcode idiv 108 1 nil) -(define-opcode ldiv 109 1 nil) -(define-opcode fdiv 110 1 nil) -(define-opcode ddiv 111 1 nil) -(define-opcode irem 112 1 nil) -(define-opcode lrem 113 1 nil) -(define-opcode frem 114 1 nil) -(define-opcode drem 115 1 nil) -(define-opcode ineg 116 1 0) -(define-opcode lneg 117 1 0) -(define-opcode fneg 118 1 0) -(define-opcode dneg 119 1 0) -(define-opcode ishl 120 1 -1) -(define-opcode lshl 121 1 -1) -(define-opcode ishr 122 1 -1) -(define-opcode lshr 123 1 -1) -(define-opcode iushr 124 1 nil) -(define-opcode lushr 125 1 nil) -(define-opcode iand 126 1 -1) -(define-opcode land 127 1 -2) -(define-opcode ior 128 1 -1) -(define-opcode lor 129 1 -2) -(define-opcode ixor 130 1 -1) -(define-opcode lxor 131 1 -2) -(define-opcode iinc 132 3 0) -(define-opcode i2l 133 1 1) -(define-opcode i2f 134 1 0) -(define-opcode i2d 135 1 1) -(define-opcode l2i 136 1 -1) -(define-opcode l2f 137 1 -1) -(define-opcode l2d 138 1 0) -(define-opcode f2i 139 1 nil) -(define-opcode f2l 140 1 nil) -(define-opcode f2d 141 1 1) -(define-opcode d2i 142 1 nil) -(define-opcode d2l 143 1 nil) -(define-opcode d2f 144 1 -1) -(define-opcode i2b 145 1 nil) -(define-opcode i2c 146 1 nil) -(define-opcode i2s 147 1 nil) -(define-opcode lcmp 148 1 -3) -(define-opcode fcmpl 149 1 -1) -(define-opcode fcmpg 150 1 -1) -(define-opcode dcmpl 151 1 -3) -(define-opcode dcmpg 152 1 -3) -(define-opcode ifeq 153 3 -1) -(define-opcode ifne 154 3 -1) -(define-opcode iflt 155 3 -1) -(define-opcode ifge 156 3 -1) -(define-opcode ifgt 157 3 -1) -(define-opcode ifle 158 3 -1) -(define-opcode if_icmpeq 159 3 -2) -(define-opcode if_icmpne 160 3 -2) -(define-opcode if_icmplt 161 3 -2) -(define-opcode if_icmpge 162 3 -2) -(define-opcode if_icmpgt 163 3 -2) -(define-opcode if_icmple 164 3 -2) -(define-opcode if_acmpeq 165 3 -2) -(define-opcode if_acmpne 166 3 -2) -(define-opcode goto 167 3 0) -;;(define-opcode jsr 168 3 1) Don't use these 2 opcodes: deprecated -;;(define-opcode ret 169 2 0) their use results in JVM verifier errors -(define-opcode tableswitch 170 0 nil) -(define-opcode lookupswitch 171 0 nil) -(define-opcode ireturn 172 1 nil) -(define-opcode lreturn 173 1 nil) -(define-opcode freturn 174 1 nil) -(define-opcode dreturn 175 1 nil) -(define-opcode areturn 176 1 -1) -(define-opcode return 177 1 0) -(define-opcode getstatic 178 3 1) -(define-opcode putstatic 179 3 -1) -(define-opcode getfield 180 3 0) -(define-opcode putfield 181 3 -2) -(define-opcode invokevirtual 182 3 nil) -(define-opcode invokespecial 183 3 nil) -(define-opcode invokestatic 184 3 nil) -(define-opcode invokeinterface 185 5 nil) -(define-opcode unused 186 0 nil) -(define-opcode new 187 3 1) -(define-opcode newarray 188 2 nil) -(define-opcode anewarray 189 3 0) -(define-opcode arraylength 190 1 0) -(define-opcode athrow 191 1 0) -(define-opcode checkcast 192 3 0) -(define-opcode instanceof 193 3 0) -(define-opcode monitorenter 194 1 -1) -(define-opcode monitorexit 195 1 -1) -(define-opcode wide 196 0 nil) -(define-opcode multianewarray 197 4 nil) -(define-opcode ifnull 198 3 -1) -(define-opcode ifnonnull 199 3 nil) -(define-opcode goto_w 200 5 nil) -;; (define-opcode jsr_w 201 5 nil) Don't use: deprecated -(define-opcode label 202 0 0) ;; virtual: does not exist in the JVM -;; (define-opcode push-value 203 nil 1) -;; (define-opcode store-value 204 nil -1) -(define-opcode clear-values 205 0 0) ;; virtual: does not exist in the JVM -;;(define-opcode var-ref 206 0 0)|# + :todo) #| Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp ============================================================================== --- branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp (original) +++ branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Mon Oct 25 18:17:28 2010 @@ -31,230 +31,338 @@ (in-package #:jvm) - ;; OPCODES (defconst *opcode-table* (make-array 256)) (defconst *opcodes* (make-hash-table :test 'equalp)) -(defstruct jvm-opcode name number size stack-effect) +(defstruct jvm-opcode name number size stack-effect effect-function) -(defun %define-opcode (name number size stack-effect) +(defun %define-opcode (name number size stack-effect effect-function) (declare (type fixnum number size)) (let* ((name (string name)) (opcode (make-jvm-opcode :name name :number number :size size - :stack-effect stack-effect))) + :stack-effect stack-effect + :effect-function effect-function))) (setf (svref *opcode-table* number) opcode) (setf (gethash name *opcodes*) opcode) (setf (gethash number *opcodes*) opcode))) -(defmacro define-opcode (name number size stack-effect) - `(%define-opcode ',name ,number ,size ,stack-effect)) +(defmacro define-opcode (name number size stack-effect &body body) + `(%define-opcode ',name ,number ,size ,stack-effect + ,(if (and (symbolp (car body)) (null (cdr body))) + (if (null (car body)) + #'identity + `(function ,(car body))) + `(lambda (instruction) + (declare (ignorable instruction)) + , at body)))) ;; name number size stack-effect (nil if unknown) (define-opcode nop 0 1 0) -(define-opcode aconst_null 1 1 1) -(define-opcode iconst_m1 2 1 1) -(define-opcode iconst_0 3 1 1) -(define-opcode iconst_1 4 1 1) -(define-opcode iconst_2 5 1 1) -(define-opcode iconst_3 6 1 1) -(define-opcode iconst_4 7 1 1) -(define-opcode iconst_5 8 1 1) -(define-opcode lconst_0 9 1 2) -(define-opcode lconst_1 10 1 2) -(define-opcode fconst_0 11 1 1) -(define-opcode fconst_1 12 1 1) -(define-opcode fconst_2 13 1 1) -(define-opcode dconst_0 14 1 2) -(define-opcode dconst_1 15 1 2) -(define-opcode bipush 16 2 1) -(define-opcode sipush 17 3 1) -(define-opcode ldc 18 2 1) -(define-opcode ldc_w 19 3 1) -(define-opcode ldc2_w 20 3 2) -(define-opcode iload 21 2 1) -(define-opcode lload 22 2 2) -(define-opcode fload 23 2 nil) -(define-opcode dload 24 2 nil) -(define-opcode aload 25 2 1) -(define-opcode iload_0 26 1 1) -(define-opcode iload_1 27 1 1) -(define-opcode iload_2 28 1 1) -(define-opcode iload_3 29 1 1) -(define-opcode lload_0 30 1 2) -(define-opcode lload_1 31 1 2) -(define-opcode lload_2 32 1 2) -(define-opcode lload_3 33 1 2) -(define-opcode fload_0 34 1 nil) -(define-opcode fload_1 35 1 nil) -(define-opcode fload_2 36 1 nil) -(define-opcode fload_3 37 1 nil) -(define-opcode dload_0 38 1 nil) -(define-opcode dload_1 39 1 nil) -(define-opcode dload_2 40 1 nil) -(define-opcode dload_3 41 1 nil) -(define-opcode aload_0 42 1 1) -(define-opcode aload_1 43 1 1) -(define-opcode aload_2 44 1 1) -(define-opcode aload_3 45 1 1) -(define-opcode iaload 46 1 -1) -(define-opcode laload 47 1 0) -(define-opcode faload 48 1 -1) -(define-opcode daload 49 1 0) -(define-opcode aaload 50 1 -1) -(define-opcode baload 51 1 nil) -(define-opcode caload 52 1 nil) -(define-opcode saload 53 1 nil) -(define-opcode istore 54 2 -1) -(define-opcode lstore 55 2 -2) -(define-opcode fstore 56 2 nil) -(define-opcode dstore 57 2 nil) -(define-opcode astore 58 2 -1) -(define-opcode istore_0 59 1 -1) -(define-opcode istore_1 60 1 -1) -(define-opcode istore_2 61 1 -1) -(define-opcode istore_3 62 1 -1) -(define-opcode lstore_0 63 1 -2) -(define-opcode lstore_1 64 1 -2) -(define-opcode lstore_2 65 1 -2) -(define-opcode lstore_3 66 1 -2) -(define-opcode fstore_0 67 1 nil) -(define-opcode fstore_1 68 1 nil) -(define-opcode fstore_2 69 1 nil) -(define-opcode fstore_3 70 1 nil) -(define-opcode dstore_0 71 1 nil) -(define-opcode dstore_1 72 1 nil) -(define-opcode dstore_2 73 1 nil) -(define-opcode dstore_3 74 1 nil) -(define-opcode astore_0 75 1 -1) -(define-opcode astore_1 76 1 -1) -(define-opcode astore_2 77 1 -1) -(define-opcode astore_3 78 1 -1) -(define-opcode iastore 79 1 -3) -(define-opcode lastore 80 1 -4) -(define-opcode fastore 81 1 -3) -(define-opcode dastore 82 1 -4) -(define-opcode aastore 83 1 -3) -(define-opcode bastore 84 1 nil) -(define-opcode castore 85 1 nil) -(define-opcode sastore 86 1 nil) -(define-opcode pop 87 1 -1) -(define-opcode pop2 88 1 -2) -(define-opcode dup 89 1 1) -(define-opcode dup_x1 90 1 1) -(define-opcode dup_x2 91 1 1) -(define-opcode dup2 92 1 2) -(define-opcode dup2_x1 93 1 2) -(define-opcode dup2_x2 94 1 2) -(define-opcode swap 95 1 0) -(define-opcode iadd 96 1 -1) -(define-opcode ladd 97 1 -2) -(define-opcode fadd 98 1 -1) -(define-opcode dadd 99 1 -2) -(define-opcode isub 100 1 -1) -(define-opcode lsub 101 1 -2) -(define-opcode fsub 102 1 -1) -(define-opcode dsub 103 1 -2) -(define-opcode imul 104 1 -1) -(define-opcode lmul 105 1 -2) -(define-opcode fmul 106 1 -1) -(define-opcode dmul 107 1 -2) -(define-opcode idiv 108 1 nil) -(define-opcode ldiv 109 1 nil) -(define-opcode fdiv 110 1 nil) -(define-opcode ddiv 111 1 nil) -(define-opcode irem 112 1 nil) -(define-opcode lrem 113 1 nil) -(define-opcode frem 114 1 nil) -(define-opcode drem 115 1 nil) +(define-opcode aconst_null 1 1 1 (smf-push :null)) +(define-opcode iconst_m1 2 1 1 (smf-push :int)) +(define-opcode iconst_0 3 1 1 (smf-push :int)) +(define-opcode iconst_1 4 1 1 (smf-push :int)) +(define-opcode iconst_2 5 1 1 (smf-push :int)) +(define-opcode iconst_3 6 1 1 (smf-push :int)) +(define-opcode iconst_4 7 1 1 (smf-push :int)) +(define-opcode iconst_5 8 1 1 (smf-push :int)) +(define-opcode lconst_0 9 1 2 (smf-push :long)) +(define-opcode lconst_1 10 1 2 (smf-push :long)) +(define-opcode fconst_0 11 1 1 (smf-push :float)) +(define-opcode fconst_1 12 1 1 (smf-push :float)) +(define-opcode fconst_2 13 1 1 (smf-push :float)) +(define-opcode dconst_0 14 1 2 (smf-push :double)) +(define-opcode dconst_1 15 1 2 (smf-push :duble)) +(define-opcode bipush 16 2 1 (smf-push :int)) +(define-opcode sipush 17 3 1 (smf-push :int)) +(define-opcode ldc 18 2 1 (smf-push (car (instruction-args instruction)))) +(define-opcode ldc_w 19 3 1 (smf-push (car (instruction-args instruction)))) +(define-opcode ldc2_w 20 3 2 + (smf-push (car (instruction-args instruction))) + (smf-push :top)) +(define-opcode iload 21 2 1 (smf-push :int)) +(define-opcode lload 22 2 2 (smf-push :long)) +(define-opcode fload 23 2 nil (smf-push :float)) +(define-opcode dload 24 2 nil (smf-push :double)) +(define-opcode aload 25 2 1 + (smf-push (smf-get (car (instruction-args instruction))))) +(define-opcode iload_0 26 1 1 (smf-push :int)) +(define-opcode iload_1 27 1 1 (smf-push :int)) +(define-opcode iload_2 28 1 1 (smf-push :int)) +(define-opcode iload_3 29 1 1 (smf-push :int)) +(define-opcode lload_0 30 1 2 (smf-push :long)) +(define-opcode lload_1 31 1 2 (smf-push :long)) +(define-opcode lload_2 32 1 2 (smf-push :long)) +(define-opcode lload_3 33 1 2 (smf-push :long)) +(define-opcode fload_0 34 1 nil (smf-push :float)) +(define-opcode fload_1 35 1 nil (smf-push :float)) +(define-opcode fload_2 36 1 nil (smf-push :float)) +(define-opcode fload_3 37 1 nil (smf-push :float)) +(define-opcode dload_0 38 1 nil (smf-push :double)) +(define-opcode dload_1 39 1 nil (smf-push :double)) +(define-opcode dload_2 40 1 nil (smf-push :double)) +(define-opcode dload_3 41 1 nil (smf-push :double)) +(define-opcode aload_0 42 1 1 (smf-push (smf-get 0))) +(define-opcode aload_1 43 1 1 (smf-push (smf-get 1))) +(define-opcode aload_2 44 1 1 (smf-push (smf-get 2))) +(define-opcode aload_3 45 1 1 (smf-push (smf-get 3))) +(define-opcode iaload 46 1 -1 (smf-popn 2) (smf-push :int)) +(define-opcode laload 47 1 0 (smf-popn 2) (smf-push :long)) +(define-opcode faload 48 1 -1 (smf-popn 2) (smf-push :float)) +(define-opcode daload 49 1 0 (smf-popn 2) (smf-push :double)) +(define-opcode aaload 50 1 -1 + (progn + (smf-pop) + (smf-push (smf-element-of (smf-pop))))) +(define-opcode baload 51 1 nil (smf-popn 2) (smf-push :int)) +(define-opcode caload 52 1 nil (smf-popn 2) (smf-push :int)) +(define-opcode saload 53 1 nil (smf-popn 2) (smf-push :int)) + +(defun iaf-store-effect (arg) + (let ((t1 (smf-pop))) + (sys::%format t "iaf-store ~S~%" (list arg t1)) + (smf-set arg t1) + (when (> arg 0) + (let ((t2 (smf-get (1- arg)))) + (when (or (eq t2 :long) (eq t2 :double)) + (smf-set (1- arg) :top)))))) + +(defun ld-store-effect (arg) + (smf-pop) + (let ((t1 (smf-pop))) + (smf-set arg t1) + (smf-set (1+ arg) :top) + (when (> arg 0) + (let ((t2 (smf-get (1- arg)))) + (when (or (eq t2 :long) (eq t2 :double)) + (smf-set (1- arg) :top)))))) + +(define-opcode istore 54 2 -1 + (iaf-store-effect (car (instruction-args instruction)))) +(define-opcode lstore 55 2 -2 + (ld-store-effect (car (instruction-args instruction)))) +(define-opcode fstore 56 2 nil + (iaf-store-effect (car (instruction-args instruction)))) +(define-opcode dstore 57 2 nil + (ld-store-effect (car (instruction-args instruction)))) +(define-opcode astore 58 2 -1 + (iaf-store-effect (car (instruction-args instruction)))) +(define-opcode istore_0 59 1 -1 (iaf-store-effect 0)) +(define-opcode istore_1 60 1 -1 (iaf-store-effect 1)) +(define-opcode istore_2 61 1 -1 (iaf-store-effect 2)) +(define-opcode istore_3 62 1 -1 (iaf-store-effect 3)) +(define-opcode lstore_0 63 1 -2 (ld-store-effect 0)) +(define-opcode lstore_1 64 1 -2 (ld-store-effect 1)) +(define-opcode lstore_2 65 1 -2 (ld-store-effect 2)) +(define-opcode lstore_3 66 1 -2 (ld-store-effect 3)) +(define-opcode fstore_0 67 1 nil (iaf-store-effect 0)) +(define-opcode fstore_1 68 1 nil (iaf-store-effect 1)) +(define-opcode fstore_2 69 1 nil (iaf-store-effect 2)) +(define-opcode fstore_3 70 1 nil (iaf-store-effect 3)) +(define-opcode dstore_0 71 1 nil (dl-store-effect 0)) +(define-opcode dstore_1 72 1 nil (dl-store-effect 1)) +(define-opcode dstore_2 73 1 nil (dl-store-effect 2)) +(define-opcode dstore_3 74 1 nil (dl-store-effect 3)) +(define-opcode astore_0 75 1 -1 (iaf-store-effect 0)) +(define-opcode astore_1 76 1 -1 (iaf-store-effect 1)) +(define-opcode astore_2 77 1 -1 (iaf-store-effect 2)) +(define-opcode astore_3 78 1 -1 (iaf-store-effect 3)) +(define-opcode iastore 79 1 -3 (smf-popn 3)) +(define-opcode lastore 80 1 -4 (smf-popn 4)) +(define-opcode fastore 81 1 -3 (smf-popn 3)) +(define-opcode dastore 82 1 -4 (smf-popn 4)) +(define-opcode aastore 83 1 -3 (smf-popn 3)) +(define-opcode bastore 84 1 nil (smf-popn 3)) +(define-opcode castore 85 1 nil (smf-popn 3)) +(define-opcode sastore 86 1 nil (smf-popn 3)) +(define-opcode pop 87 1 -1 (smf-pop)) +(define-opcode pop2 88 1 -2 (smf-popn 2)) +(define-opcode dup 89 1 1 + (let ((t1 (smf-pop))) + (smf-push t1) + (smf-push t1))) +(define-opcode dup_x1 90 1 1 + (let ((t1 (smf-pop)) (t2 (smf-pop))) + (smf-push t1) + (smf-push t2) + (smf-push t1))) +(define-opcode dup_x2 91 1 1 + (let ((t1 (smf-pop)) (t2 (smf-pop)) (t3 (smf-pop))) + (smf-push t1) + (smf-push t3) + (smf-push t2) + (smf-push t1))) +(define-opcode dup2 92 1 2 + (let ((t1 (smf-pop)) (t2 (smf-pop))) + (smf-push t2) + (smf-push t1) + (smf-push t2) + (smf-push t1))) +(define-opcode dup2_x1 93 1 2 + (let ((t1 (smf-pop)) (t2 (smf-pop)) (t3 (smf-pop))) + (smf-push t2) + (smf-push t1) + (smf-push t3) + (smf-push t2) + (smf-push t1))) +(define-opcode dup2_x2 94 1 2 + (let ((t1 (smf-pop)) (t2 (smf-pop)) + (t3 (smf-pop)) (t4 (smf-pop))) + (smf-push t2) + (smf-push t1) + (smf-push t4) + (smf-push t3) + (smf-push t2) + (smf-push t1))) +(define-opcode swap 95 1 0 + (let ((t1 (smf-pop)) (t2 (smf-pop))) + (smf-push t1) + (smf-push t2))) +(define-opcode iadd 96 1 -1 (smf-popn 2) (smf-push :int)) +(define-opcode ladd 97 1 -2 (smf-popn 4) (smf-push :long)) +(define-opcode fadd 98 1 -1 (smf-popn 2) (smf-push :float)) +(define-opcode dadd 99 1 -2 (smf-popn 4) (smf-push :double)) +(define-opcode isub 100 1 -1 (smf-popn 2) (smf-push :int)) +(define-opcode lsub 101 1 -2 (smf-popn 4) (smf-push :long)) +(define-opcode fsub 102 1 -1 (smf-popn 2) (smf-push :float)) +(define-opcode dsub 103 1 -2 (smf-popn 4) (smf-push :double)) +(define-opcode imul 104 1 -1 (smf-popn 2) (smf-push :int)) +(define-opcode lmul 105 1 -2 (smf-popn 4) (smf-push :long)) +(define-opcode fmul 106 1 -1 (smf-popn 2) (smf-push :float)) +(define-opcode dmul 107 1 -2 (smf-popn 4) (smf-push :double)) +(define-opcode idiv 108 1 nil (smf-popn 2) (smf-push :int)) +(define-opcode ldiv 109 1 nil (smf-popn 4) (smf-push :long)) +(define-opcode fdiv 110 1 nil (smf-popn 2) (smf-push :float)) +(define-opcode ddiv 111 1 nil (smf-popn 4) (smf-push :double)) +(define-opcode irem 112 1 nil (smf-popn 2) (smf-push :int)) +(define-opcode lrem 113 1 nil (smf-popn 4) (smf-push :long)) +(define-opcode frem 114 1 nil (smf-popn 2) (smf-push :float)) +(define-opcode drem 115 1 nil (smf-popn 4) (smf-push :double)) (define-opcode ineg 116 1 0) (define-opcode lneg 117 1 0) (define-opcode fneg 118 1 0) (define-opcode dneg 119 1 0) -(define-opcode ishl 120 1 -1) -(define-opcode lshl 121 1 -1) -(define-opcode ishr 122 1 -1) -(define-opcode lshr 123 1 -1) -(define-opcode iushr 124 1 nil) -(define-opcode lushr 125 1 nil) -(define-opcode iand 126 1 -1) -(define-opcode land 127 1 -2) -(define-opcode ior 128 1 -1) -(define-opcode lor 129 1 -2) -(define-opcode ixor 130 1 -1) -(define-opcode lxor 131 1 -2) -(define-opcode iinc 132 3 0) -(define-opcode i2l 133 1 1) -(define-opcode i2f 134 1 0) -(define-opcode i2d 135 1 1) -(define-opcode l2i 136 1 -1) -(define-opcode l2f 137 1 -1) -(define-opcode l2d 138 1 0) -(define-opcode f2i 139 1 nil) -(define-opcode f2l 140 1 nil) -(define-opcode f2d 141 1 1) -(define-opcode d2i 142 1 nil) -(define-opcode d2l 143 1 nil) -(define-opcode d2f 144 1 -1) +(define-opcode ishl 120 1 -1 (smf-popn 2) (smf-push :int)) +(define-opcode lshl 121 1 -1 (smf-popn 3) (smf-push :long)) +(define-opcode ishr 122 1 -1 (smf-popn 2) (smf-push :int)) +(define-opcode lshr 123 1 -1 (smf-popn 3) (smf-push :long)) +(define-opcode iushr 124 1 nil (smf-popn 2) (smf-push :int)) +(define-opcode lushr 125 1 nil (smf-popn 3) (smf-push :long)) +(define-opcode iand 126 1 -1 (smf-popn 2) (smf-push :int)) +(define-opcode land 127 1 -2 (smf-popn 4) (smf-push :long)) +(define-opcode ior 128 1 -1 (smf-popn 2) (smf-push :int)) +(define-opcode lor 129 1 -2 (smf-popn 4) (smf-push :long)) +(define-opcode ixor 130 1 -1 (smf-popn 2) (smf-push :int)) +(define-opcode lxor 131 1 -2 (smf-popn 4) (smf-push :long)) +(define-opcode iinc 132 3 0 + (sys::%format t "AAAAAAAAAAAA ~A~%" (instruction-args instruction)) + (smf-set (car (instruction-args instruction)) :int)) +(define-opcode i2l 133 1 1 (smf-pop) (smf-push :long)) +(define-opcode i2f 134 1 0 (smf-pop) (smf-push :float)) +(define-opcode i2d 135 1 1 (smf-pop) (smf-push :double)) +(define-opcode l2i 136 1 -1 (smf-popn 2) (smf-push :int)) +(define-opcode l2f 137 1 -1 (smf-popn 2) (smf-push :float)) +(define-opcode l2d 138 1 0 (smf-popn 2) (smf-push :double)) +(define-opcode f2i 139 1 nil (smf-pop) (smf-push :int)) +(define-opcode f2l 140 1 nil (smf-pop) (smf-push :long)) +(define-opcode f2d 141 1 1 (smf-pop) (smf-push :double)) +(define-opcode d2i 142 1 nil (smf-popn 2) (smf-push :int)) +(define-opcode d2l 143 1 nil (smf-popn 2) (smf-push :long)) +(define-opcode d2f 144 1 -1 (smf-popn 2) (smf-push :float)) (define-opcode i2b 145 1 nil) (define-opcode i2c 146 1 nil) (define-opcode i2s 147 1 nil) -(define-opcode lcmp 148 1 -3) -(define-opcode fcmpl 149 1 -1) -(define-opcode fcmpg 150 1 -1) -(define-opcode dcmpl 151 1 -3) -(define-opcode dcmpg 152 1 -3) -(define-opcode ifeq 153 3 -1) -(define-opcode ifne 154 3 -1) -(define-opcode iflt 155 3 -1) -(define-opcode ifge 156 3 -1) -(define-opcode ifgt 157 3 -1) -(define-opcode ifle 158 3 -1) -(define-opcode if_icmpeq 159 3 -2) -(define-opcode if_icmpne 160 3 -2) -(define-opcode if_icmplt 161 3 -2) -(define-opcode if_icmpge 162 3 -2) -(define-opcode if_icmpgt 163 3 -2) -(define-opcode if_icmple 164 3 -2) -(define-opcode if_acmpeq 165 3 -2) -(define-opcode if_acmpne 166 3 -2) +(define-opcode lcmp 148 1 -3 (smf-popn 4) (smf-push :int)) +(define-opcode fcmpl 149 1 -1 (smf-popn 2) (smf-push :int)) +(define-opcode fcmpg 150 1 -1 (smf-popn 2) (smf-push :int)) +(define-opcode dcmpl 151 1 -3 (smf-popn 4) (smf-push :int)) +(define-opcode dcmpg 152 1 -3 (smf-popn 4) (smf-push :int)) +(define-opcode ifeq 153 3 -1 (smf-pop)) +(define-opcode ifne 154 3 -1 (smf-pop)) +(define-opcode iflt 155 3 -1 (smf-pop)) +(define-opcode ifge 156 3 -1 (smf-pop)) +(define-opcode ifgt 157 3 -1 (smf-pop)) +(define-opcode ifle 158 3 -1 (smf-pop)) +(define-opcode if_icmpeq 159 3 -2 (smf-popn 2)) +(define-opcode if_icmpne 160 3 -2 (smf-popn 2)) +(define-opcode if_icmplt 161 3 -2 (smf-popn 2)) +(define-opcode if_icmpge 162 3 -2 (smf-popn 2)) +(define-opcode if_icmpgt 163 3 -2 (smf-popn 2)) +(define-opcode if_icmple 164 3 -2 (smf-popn 2)) +(define-opcode if_acmpeq 165 3 -2 (smf-popn 2)) +(define-opcode if_acmpne 166 3 -2 (smf-popn 2)) (define-opcode goto 167 3 0) ;;(define-opcode jsr 168 3 1) Don't use these 2 opcodes: deprecated ;;(define-opcode ret 169 2 0) their use results in JVM verifier errors -(define-opcode tableswitch 170 0 nil) -(define-opcode lookupswitch 171 0 nil) -(define-opcode ireturn 172 1 nil) -(define-opcode lreturn 173 1 nil) -(define-opcode freturn 174 1 nil) -(define-opcode dreturn 175 1 nil) -(define-opcode areturn 176 1 -1) +(define-opcode tableswitch 170 0 nil (smf-pop)) +(define-opcode lookupswitch 171 0 nil (smf-pop)) +(define-opcode ireturn 172 1 nil (smf-pop)) +(define-opcode lreturn 173 1 nil (smf-popn 2)) +(define-opcode freturn 174 1 nil (smf-pop)) +(define-opcode dreturn 175 1 nil (smf-popn 2)) +(define-opcode areturn 176 1 -1 (smf-pop)) (define-opcode return 177 1 0) -(define-opcode getstatic 178 3 1) -(define-opcode putstatic 179 3 -1) -(define-opcode getfield 180 3 0) -(define-opcode putfield 181 3 -2) -(define-opcode invokevirtual 182 3 nil) -(define-opcode invokespecial 183 3 nil) -(define-opcode invokestatic 184 3 nil) -(define-opcode invokeinterface 185 5 nil) -(define-opcode unused 186 0 nil) -(define-opcode new 187 3 1) -(define-opcode newarray 188 2 nil) -(define-opcode anewarray 189 3 0) -(define-opcode arraylength 190 1 0) -(define-opcode athrow 191 1 0) -(define-opcode checkcast 192 3 0) -(define-opcode instanceof 193 3 0) -(define-opcode monitorenter 194 1 -1) -(define-opcode monitorexit 195 1 -1) +(define-opcode getstatic 178 3 1 + (sys::%format t "GETSTATIC ~A~%" (third (instruction-args instruction))) + ;;TODO!!! + (smf-push (third (instruction-args instruction)))) +(define-opcode putstatic 179 3 -1 + (sys::%format t "PUTSTATIC ~A~%" (third (instruction-args instruction))) + (smf-popt (third (instruction-args instruction)))) +(define-opcode getfield 180 3 0 + (smf-pop) + (smf-push (third (instruction-args instruction)))) +(define-opcode putfield 181 3 -2 + (smf-popt (third (instruction-args instruction))) + (smf-pop)) +(define-opcode invokevirtual 182 3 nil + (smf-popt (third (instruction-args instruction))) + (smf-pop) + (smf-push (third (instruction-args instruction)))) +(define-opcode invokespecial 183 3 nil + (smf-popt (third (instruction-args instruction))) + (smf-pop) + (smf-push (third (instruction-args instruction)))) +(define-opcode invokestatic 184 3 nil + (sys::%format t "invokestatic ~S~%" (instruction-args instruction)) + (smf-popt (third (instruction-args instruction))) + (smf-push (third (instruction-args instruction)))) +(define-opcode invokeinterface 185 5 nil + (smf-popt (third (instruction-args instruction))) + (smf-pop) + (smf-push (third (instruction-args instruction)))) +(define-opcode invokedynamic 186 0 nil + (smf-popt (second (instruction-args instruction))) + (smf-push (second (instruction-args instruction)))) +(define-opcode new 187 3 1 + (smf-push (first (instruction-args instruction)))) +(define-opcode newarray 188 2 nil + (smf-pop) + (smf-push `(:array-of ,(first (instruction-args instruction))))) +(define-opcode anewarray 189 3 0 + (smf-pop) + (smf-push `(:array-of ,(first (instruction-args instruction))))) +(define-opcode arraylength 190 1 0 + (smf-pop) + (smf-push :int)) +(define-opcode athrow 191 1 0 (smf-pop)) +(define-opcode checkcast 192 3 0 + (smf-pop) + (smf-push (first (instruction-args instruction)))) +(define-opcode instanceof 193 3 0 + (smf-pop) + (smf-push :int)) +(define-opcode monitorenter 194 1 -1 (smf-pop)) +(define-opcode monitorexit 195 1 -1 (smf-pop)) (define-opcode wide 196 0 nil) (define-opcode multianewarray 197 4 nil) -(define-opcode ifnull 198 3 -1) -(define-opcode ifnonnull 199 3 nil) +(define-opcode ifnull 198 3 -1 (smf-pop)) +(define-opcode ifnonnull 199 3 nil (smf-pop)) (define-opcode goto_w 200 5 nil) ;; (define-opcode jsr_w 201 5 nil) Don't use: deprecated (define-opcode label 202 0 0) ;; virtual: does not exist in the JVM @@ -278,6 +386,7 @@ (jvm-opcode-number opcode) (error "Unknown opcode ~S." opcode-name)))) + (declaim (ftype (function (t) fixnum) opcode-size)) (defun opcode-size (opcode-number) (declare (optimize speed (safety 0))) @@ -289,8 +398,51 @@ (declare (optimize speed)) (jvm-opcode-stack-effect (svref *opcode-table* opcode-number))) +(declaim (ftype (function (t) t) opcode-effect-function)) +(defun opcode-effect-function (opcode-number) + (declare (optimize speed)) + (jvm-opcode-effect-function (svref *opcode-table* opcode-number))) - +;;Stack map table functions +(defun smf-get (pos) + (or (nth pos *code-locals*) + (sys::%format t "Locals inconsistency: get ~A but locals are ~A~%" ;;TODO error + pos *code-locals*))) + +(defun smf-set (pos type) + (if (< pos (length *code-locals*)) + (setf (nth pos *code-locals*) type) + (progn + (setf *code-locals* + (append *code-locals* (list nil))) + (smf-set pos type)))) + +(defun smf-push (type) + (push type *code-stack*) + (when (or (eq type :long) (eq type :double)) + (push :top *code-stack))) + +(defun smf-pop () + ;(sys::%format t "smf-pop ~A~%" *code-stack*) + (pop *code-stack*)) + +(defun smf-popt (type) + (declare (ignore type)) ;TODO + (pop *code-stack*)) + +(defun smf-popn (n) + (dotimes (i n) + (pop *code-stack*))) + +(defun smf-element-of (type) + (if (and (consp type) (eq (car type) :array-of)) + (cdr type) + (cons :element-of type))) + +(defun smf-array-of (type) + (if (and (consp type) (eq (car type) :element-of)) + (cdr type) + (cons :array-of type))) ;; INSTRUCTION @@ -299,7 +451,13 @@ args stack depth - wide) + wide + input-locals + input-stack + output-locals + output-stack + ;;the calculated offset of the instruction + offset) (defun make-instruction (opcode args) (let ((inst (apply #'%make-instruction @@ -307,6 +465,8 @@ (remove :wide-prefix args))))) (when (memq :wide-prefix args) (setf (inst-wide inst) t)) + (setf (instruction-input-locals inst) *code-locals*) + (setf (instruction-input-stack inst) *code-stack*) inst)) (defun print-instruction (instruction) @@ -340,6 +500,8 @@ ;; We need to have APIs to address this, but for now pass2 is ;; our only user and we'll hard-code the use of *code*. (defvar *code* nil) +(defvar *code-locals* nil) +(defvar *code-stack* nil) (defknown %%emit * t) (defun %%emit (instr &rest args) @@ -360,9 +522,17 @@ (eq (car instr) 'QUOTE) (symbolp (cadr instr))) (setf instr (opcode-number (cadr instr)))) - (if (fixnump instr) - `(%%emit ,instr , at args) - `(%emit ,instr , at args))) + (let ((instruction (gensym))) + `(let ((,instruction + ,(if (fixnump instr) + `(%%emit ,instr , at args) + `(%emit ,instr , at args)))) + ;(sys::%format t "EMIT ~S ~S~%" ',instr ',args) + (funcall (opcode-effect-function (instruction-opcode ,instruction)) + ,instruction) + (setf (instruction-output-locals ,instruction) *code-locals*) + (setf (instruction-output-stack ,instruction) *code-stack*) + ,instruction))) ;; Helper routines @@ -395,8 +565,8 @@ (declaim (ftype (function (t) t) branch-p) (inline branch-p)) (defun branch-p (opcode) -;; (declare (optimize speed)) -;; (declare (type '(integer 0 255) opcode)) + (declare (optimize speed)) + (declare (type '(integer 0 255) opcode)) (or (<= 153 opcode 167) (<= 198 opcode 200))) ;; ifnull / ifnonnull / goto_w Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm.lisp Mon Oct 25 18:17:28 2010 @@ -124,7 +124,8 @@ class-name lambda-name lambda-list ; as advertised - static-code + static-initializer + constructor objects ;; an alist of externalized objects and their field names (functions (make-hash-table :test 'equal)) ;; because of (SETF ...) functions ) @@ -163,7 +164,18 @@ :class-name class-name :lambda-name lambda-name :lambda-list lambda-list - :access-flags '(:public :final)))) + :access-flags '(:public :final))) + (static-initializer (make-method :static-initializer + :void nil :flags '(:public :static))) + (constructor (make-method :constructor :void nil + :flags '(:public)))) + + (setf (abcl-class-file-static-initializer class-file) static-initializer) + (class-add-method class-file static-initializer) + + (setf (abcl-class-file-constructor class-file) constructor) + (class-add-method class-file constructor) + (when *file-compilation* (let ((source-attribute (make-source-file-attribute @@ -176,12 +188,10 @@ `(let* ((,var ,class-file) (*class-file* ,var) (*pool* (abcl-class-file-constants ,var)) - (*static-code* (abcl-class-file-static-code ,var)) (*externalized-objects* (abcl-class-file-objects ,var)) (*declared-functions* (abcl-class-file-functions ,var))) (progn , at body) - (setf (abcl-class-file-static-code ,var) *static-code* - (abcl-class-file-objects ,var) *externalized-objects* + (setf (abcl-class-file-objects ,var) *externalized-objects* (abcl-class-file-functions ,var) *declared-functions*)))) (defstruct compiland From astalla at common-lisp.net Sat Oct 30 00:16:00 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 29 Oct 2010 20:16:00 -0400 Subject: [armedbear-cvs] r12984 - branches/invokedynamic/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Fri Oct 29 20:15:58 2010 New Revision: 12984 Log: [invokedynamic] Instruction effects are simulated at code resolving time, not emit time. Stack map frames not yet emitted: compilation fails early. More consistency in how constant indexes are handled. Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/compiler-pass2.lisp branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/invokedynamic/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/invokedynamic/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Oct 29 20:15:58 2010 @@ -204,10 +204,12 @@ (declaim (ftype (function * t) emit-invokestatic)) (defun emit-invokestatic (class-name method-name arg-types return-type) (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types)) - (index (constant-index (pool-add-method-ref - *pool* class-name - method-name (cons return-type arg-types)))) - (instruction (apply #'%emit 'invokestatic (u2 index)))) + (method (pool-add-method-ref + *pool* class-name + method-name (cons return-type arg-types))) + (instruction (%emit 'invokestatic method))) + (when (string= method-name "recall") + (sys::%format t "RECALL!!! ~S ~S~%" (cons return-type arg-types) method)) (setf (instruction-stack instruction) stack-effect))) @@ -226,10 +228,10 @@ (defknown emit-invokevirtual (t t t t) t) (defun emit-invokevirtual (class-name method-name arg-types return-type) (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types)) - (index (constant-index (pool-add-method-ref - *pool* class-name - method-name (cons return-type arg-types)))) - (instruction (apply #'%emit 'invokevirtual (u2 index)))) + (method (pool-add-method-ref + *pool* class-name + method-name (cons return-type arg-types))) + (instruction (%emit 'invokevirtual method))) (declare (type (signed-byte 8) stack-effect)) (let ((explain *explain*)) (when (and explain (memq :java-calls explain)) @@ -244,10 +246,10 @@ (defknown emit-invokespecial-init (string list) t) (defun emit-invokespecial-init (class-name arg-types) (let* ((stack-effect (apply #'descriptor-stack-effect :void arg-types)) - (index (constant-index (pool-add-method-ref - *pool* class-name - "" (cons nil arg-types)))) - (instruction (apply #'%emit 'invokespecial (u2 index)))) + (method (pool-add-method-ref + *pool* class-name + "" (cons nil arg-types))) + (instruction (%emit 'invokespecial method))) (declare (type (signed-byte 8) stack-effect)) (setf (instruction-stack instruction) (1- stack-effect)))) @@ -287,41 +289,45 @@ (defknown emit-getstatic (t t t) t) (defun emit-getstatic (class-name field-name type) (let ((ref (pool-add-field-ref *pool* class-name field-name type))) - (apply #'%emit 'getstatic (u2 (constant-index ref))))) + (%emit 'getstatic ref))) (defknown emit-putstatic (t t t) t) (defun emit-putstatic (class-name field-name type) (let ((ref (pool-add-field-ref *pool* class-name field-name type))) - (apply #'%emit 'putstatic (u2 (constant-index ref))))) + (%emit 'putstatic ref))) (declaim (inline emit-getfield emit-putfield)) (defknown emit-getfield (t t t) t) (defun emit-getfield (class-name field-name type) (let* ((ref (pool-add-field-ref *pool* class-name field-name type))) - (apply #'%emit 'getfield (u2 (constant-index ref))))) + (%emit 'getfield ref))) (defknown emit-putfield (t t t) t) (defun emit-putfield (class-name field-name type) (let* ((ref (pool-add-field-ref *pool* class-name field-name type))) - (apply #'%emit 'putfield (u2 (constant-index ref))))) + (%emit 'putfield ref))) (defknown emit-new (t) t) (declaim (inline emit-new emit-anewarray emit-checkcast emit-instanceof)) (defun emit-new (class-name) - (apply #'%emit 'new (u2 (constant-index (pool-class class-name))))) + (let ((class (pool-class class-name))) + (%emit 'new class))) (defknown emit-anewarray (t) t) (defun emit-anewarray (class-name) - (apply #'%emit 'anewarray (u2 (constant-index (pool-class class-name))))) + (let ((class (pool-class class-name))) + (%emit 'anewarray class))) (defknown emit-checkcast (t) t) (defun emit-checkcast (class-name) - (apply #'%emit 'checkcast (u2 (constant-index (pool-class class-name))))) + (let ((class (pool-class class-name))) + (%emit 'checkcast class))) (defknown emit-instanceof (t) t) (defun emit-instanceof (class-name) - (apply #'%emit 'instanceof (u2 (constant-index (pool-class class-name))))) + (let ((class (pool-class class-name))) + (%emit 'instanceof class))) (defvar type-representations '((:int fixnum) @@ -3799,7 +3805,6 @@ :element-type '(unsigned-byte 8) :if-exists :supersede))) (with-class-file class-file - (make-constructor class-file) (let ((*current-compiland* compiland)) (with-saved-compiler-policy (p2-compiland compiland) @@ -4559,113 +4564,6 @@ (fix-boxing representation nil) (emit-move-from-stack target representation)))) -(defun p2-make-array (form target representation) - ;; In safe code, we want to make sure the requested length does not exceed - ;; ARRAY-DIMENSION-LIMIT. - (cond ((and (< *safety* 3) - (= (length form) 2) - (fixnum-type-p (derive-compiler-type (second form))) - (null representation)) - (let ((arg (second form))) - (emit-new +lisp-simple-vector+) - (emit 'dup) - (compile-forms-and-maybe-emit-clear-values arg 'stack :int) - (emit-invokespecial-init +lisp-simple-vector+ '(:int)) - (emit-move-from-stack target representation))) - (t - (compile-function-call form target representation)))) - -;; make-sequence result-type size &key initial-element => sequence -(define-inlined-function p2-make-sequence (form target representation) - ;; In safe code, we want to make sure the requested length does not exceed - ;; ARRAY-DIMENSION-LIMIT. - ((and (< *safety* 3) - (= (length form) 3) - (null representation))) - (let* ((args (cdr form)) - (arg1 (first args)) - (arg2 (second args))) - (when (and (consp arg1) - (= (length arg1) 2) - (eq (first arg1) 'QUOTE)) - (let* ((result-type (second arg1)) - (class - (case result-type - ((STRING SIMPLE-STRING) - (setf class +lisp-simple-string+)) - ((VECTOR SIMPLE-VECTOR) - (setf class +lisp-simple-vector+))))) - (when class - (emit-new class) - (emit 'dup) - (compile-forms-and-maybe-emit-clear-values arg2 'stack :int) - (emit-invokespecial-init class '(:int)) - (emit-move-from-stack target representation) - (return-from p2-make-sequence))))) - (compile-function-call form target representation)) - -(defun p2-make-string (form target representation) - ;; In safe code, we want to make sure the requested length does not exceed - ;; ARRAY-DIMENSION-LIMIT. - (cond ((and (< *safety* 3) - (= (length form) 2) - (null representation)) - (let ((arg (second form))) - (emit-new +lisp-simple-string+) - (emit 'dup) - (compile-forms-and-maybe-emit-clear-values arg 'stack :int) - (emit-invokespecial-init +lisp-simple-string+ '(:int)) - (emit-move-from-stack target representation))) - (t - (compile-function-call form target representation)))) - -(defun p2-%make-structure (form target representation) - (cond ((and (check-arg-count form 2) - (eq (derive-type (%cadr form)) 'SYMBOL)) - (emit-new +lisp-structure-object+) - (emit 'dup) - (compile-form (%cadr form) 'stack nil) - (emit-checkcast +lisp-symbol+) - (compile-form (%caddr form) 'stack nil) - (maybe-emit-clear-values (%cadr form) (%caddr form)) - (emit-invokevirtual +lisp-object+ "copyToArray" - nil +lisp-object-array+) - (emit-invokespecial-init +lisp-structure-object+ - (list +lisp-symbol+ +lisp-object-array+)) - (emit-move-from-stack target representation)) - (t - (compile-function-call form target representation)))) - -(defun p2-make-structure (form target representation) - (let* ((args (cdr form)) - (slot-forms (cdr args)) - (slot-count (length slot-forms))) - (cond ((and (<= 1 slot-count 6) - (eq (derive-type (%car args)) 'SYMBOL)) - (emit-new +lisp-structure-object+) - (emit 'dup) - (compile-form (%car args) 'stack nil) - (emit-checkcast +lisp-symbol+) - (dolist (slot-form slot-forms) - (compile-form slot-form 'stack nil)) - (apply 'maybe-emit-clear-values args) - (emit-invokespecial-init +lisp-structure-object+ - (append (list +lisp-symbol+) - (make-list slot-count :initial-element +lisp-object+))) - (emit-move-from-stack target representation)) - (t - (compile-function-call form target representation))))) - -(defun p2-make-hash-table (form target representation) - (cond ((= (length form) 1) ; no args - (emit-new +lisp-eql-hash-table+) - (emit 'dup) - (emit-invokespecial-init +lisp-eql-hash-table+ nil) - (fix-boxing representation nil) - (emit-move-from-stack target representation)) - (t - (compile-function-call form target representation)))) - (defknown p2-stream-element-type (t t t) t) (define-inlined-function p2-stream-element-type (form target representation) ((check-arg-count form 1)) @@ -6852,8 +6750,6 @@ (method (make-method "execute" +lisp-object+ arg-types :flags '(:final :public))) (code (method-add-code method)) - (*code-locals* (code-computed-locals code)) ;;TODO in this and other cases, use with-code-to-method - (*code-stack* (code-computed-stack code)) (*current-code-attribute* code) (*code* ()) (*register* 1) ;; register 0: "this" pointer @@ -6862,10 +6758,18 @@ (*thread* nil) (*initialize-thread-var* nil) - (label-START (gensym)) - prologue) + (label-START (gensym))) (class-add-method class-file method) + + (setf (abcl-class-file-superclass class-file) + (if (or *hairy-arglist-p* + (and *child-p* *closure-variables*)) + +lisp-compiled-closure+ + +lisp-primitive+)) + + (make-constructor class-file) + (when (fixnump *source-line-number*) (let ((table (make-line-numbers-attribute))) (method-add-attribute method table) @@ -6876,36 +6780,6 @@ (dolist (var (compiland-free-specials compiland)) (push var *visible-variables*)) - ;;Prologue - (let ((arity (compiland-arity compiland))) - (when arity - (generate-arg-count-check arity))) - - (when *hairy-arglist-p* - (aload 0) ; this - (aver (not (null (compiland-argument-register compiland)))) - (aload (compiland-argument-register compiland)) ; arg vector - (cond ((or (memq '&OPTIONAL args) (memq '&KEY args)) - (ensure-thread-var-initialized) - (maybe-initialize-thread-var) - (emit-push-current-thread) - (emit-invokevirtual *this-class* "processArgs" - (list +lisp-object-array+ +lisp-thread+) - +lisp-object-array+)) - (t - (emit-invokevirtual *this-class* "fastProcessArgs" - (list +lisp-object-array+) - +lisp-object-array+))) - (astore (compiland-argument-register compiland))) - - (unless (and *hairy-arglist-p* - (or (memq '&OPTIONAL args) (memq '&KEY args))) - (maybe-initialize-thread-var)) - - (setf prologue *code* - *code* ()) - ;;;; - (when *using-arg-array* (setf (compiland-argument-register compiland) (allocate-register))) @@ -7049,7 +6923,7 @@ (check-for-unused-variables (compiland-arg-vars compiland)) ;; Go back and fill in prologue. - #+nil (let ((code *code*)) + (let ((code *code*)) (setf *code* ()) (let ((arity (compiland-arity compiland))) (when arity @@ -7076,14 +6950,6 @@ (or (memq '&OPTIONAL args) (memq '&KEY args))) (maybe-initialize-thread-var)) (setf *code* (nconc code *code*))) - - (setf *code* (nconc prologue *code*)) - - (setf (abcl-class-file-superclass class-file) - (if (or *hairy-arglist-p* - (and *child-p* *closure-variables*)) - +lisp-compiled-closure+ - +lisp-primitive+)) (setf (abcl-class-file-lambda-list class-file) args) (setf (code-max-locals code) *registers-allocated*) @@ -7132,7 +6998,6 @@ ;; Pass 2. (with-class-file (compiland-class-file compiland) - (make-constructor *class-file*) (with-saved-compiler-policy (p2-compiland compiland) ;; (finalize-class-file (compiland-class-file compiland)) @@ -7374,7 +7239,6 @@ nth progn)) (install-p2-handler '%ldb 'p2-%ldb) - (install-p2-handler '%make-structure 'p2-%make-structure) (install-p2-handler '* 'p2-times) (install-p2-handler '+ 'p2-plus) (install-p2-handler '- 'p2-minus) @@ -7429,11 +7293,6 @@ (install-p2-handler 'logior 'p2-logior) (install-p2-handler 'lognot 'p2-lognot) (install-p2-handler 'logxor 'p2-logxor) - (install-p2-handler 'make-array 'p2-make-array) - (install-p2-handler 'make-hash-table 'p2-make-hash-table) - (install-p2-handler 'make-sequence 'p2-make-sequence) - (install-p2-handler 'make-string 'p2-make-string) - (install-p2-handler 'make-structure 'p2-make-structure) (install-p2-handler 'max 'p2-min/max) (install-p2-handler 'memq 'p2-memq) (install-p2-handler 'memql 'p2-memql) @@ -7494,6 +7353,6 @@ (let ((sys:*enable-autocompile* nil)) (values (compile nil function))))) -(setf sys:*enable-autocompile* t) +(setf sys:*enable-autocompile* nil) (provide "COMPILER-PASS2") Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Fri Oct 29 20:15:58 2010 @@ -229,6 +229,7 @@ (princ arg-string s)) (princ #\) s) (princ ret-string s)) + ;(sys::%format t "descriptor ~S ~S -> ~S~%" return-type argument-types str) str) ;; (format nil "(~{~A~})~A" ;; (internal-field-ref return-type)) @@ -355,12 +356,14 @@ (defstruct (constant-name/type (:constructor make-constant-name/type (index name + type descriptor)) (:include constant (tag 12))) "Structure holding information on a 'name-and-type' type item in the constant pool; this type of element is used by 'member-ref' type items." name + type descriptor) (defstruct (constant-utf8 (:constructor make-constant-utf8 (index value)) @@ -493,7 +496,8 @@ (unless entry (let ((n (pool-add-utf8 pool name)) (i-t (pool-add-utf8 pool internal-type))) - (setf entry (make-constant-name/type (incf (pool-index pool)) n i-t) + (setf entry (make-constant-name/type + (incf (pool-index pool)) n type i-t) (gethash (cons name type) (pool-entries pool)) entry)) (push entry (pool-entries-list pool))) entry)) @@ -756,7 +760,7 @@ ((3 4) (sys::%format t "f/i: ~a~%" (constant-float/int-value entry))) ((5 6) (sys::%format t "d/l: ~a~%" (constant-double/long-value entry))) ((9 10 11) (sys::%format t "ref: ~a,~a~%" - (constant-member-ref-class-index entry) + (constant-member-ref-class entry) (constant-member-ref-name/type entry))) (12 (sys::%format t "n/t: ~a,~a~%" (constant-name/type-name entry) @@ -976,8 +980,7 @@ ;; these are used for handling nested WITH-CODE-TO-METHOD blocks (current-local 0) - computed-locals - computed-stack) + computed-locals) @@ -1010,7 +1013,7 @@ (analyze-locals code))) (multiple-value-bind (c labels stack-map-table) - (resolve-code c class parent compute-stack-map-table-p) + (resolve-code code c class parent compute-stack-map-table-p) (setf (code-code code) c (code-labels code) labels) (when compute-stack-map-table-p @@ -1089,12 +1092,15 @@ :catch-type type) (code-exception-handlers code))) -(defun resolve-code (code class method compute-stack-map-table-p) +(defun resolve-code (code-attr code class method compute-stack-map-table-p) "Walks the code, replacing symbolic labels with numeric offsets, and optionally computing the stack map table." (declare (ignore class)) (let* ((length 0) labels ;; alist - stack-map-table) + stack-map-table + (computing-stack-map-table compute-stack-map-table-p) + (*code-locals* (code-computed-locals code-attr)) + *code-stack*) #|| (*basic-block* (when compute-stack-map-table-p (make-basic-block :offset 0 @@ -1102,14 +1108,31 @@ (method-initial-locals method)))) (root-block *basic-block*) *basic-blocks*)||# - compute-stack-map-table-p :todo (declare (type (unsigned-byte 16) length)) - ;; Pass 1: calculate label offsets and overall length. + ;; Pass 1: calculate label offsets and overall length and, if + ;; compute-stack-map-table-p is true, also simulate the effect of the + ;; instructions on the stack and locals. (dotimes (i (length code)) (declare (type (unsigned-byte 16) i)) (let* ((instruction (aref code i)) (opcode (instruction-opcode instruction))) (setf (instruction-offset instruction) length) + ;;(sys::format t "simulating instruction ~S ~S stack ~S locals ~S ~%" + ;;opcode (mapcar #'type-of (instruction-args instruction)) + ;;(length *code-stack*) (length *code-locals*)) + (if computing-stack-map-table + (progn + (when (= opcode 202) ;;label: simulate a jump + (record-jump-to-label (car (instruction-args instruction)))) + (simulate-instruction-effect instruction) + ;;Simulation must be stopped if we encounter a goto, it will be + ;;resumed by the next label that is the target of a jump + (setf computing-stack-map-table (not (unconditional-jump-p opcode)))) + (when (and (= opcode 202) ; LABEL + (get (first (instruction-args instruction)) + 'jump-target-p)) + (simulate-instruction-effect instruction) + (setf computing-stack-map-table t))) (if (= opcode 202) ; LABEL (let ((label (car (instruction-args instruction)))) (set label length) @@ -1127,6 +1150,8 @@ (offset (- (the (unsigned-byte 16) (symbol-value (the symbol label))) index))) + (unless (get label 'jump-target-p) + (sys::%format "error - label not target of a jump ~S~%" label)) (setf (instruction-args instruction) (s2 offset)))) (unless (= (instruction-opcode instruction) 202) ; LABEL (incf index (opcode-size (instruction-opcode instruction))))))) @@ -1141,14 +1166,29 @@ (setf (svref bytes index) (instruction-opcode instruction)) (incf index) (dolist (arg (instruction-args instruction)) - (setf (svref bytes index) - (if (constant-p arg) (constant-index arg) arg)) - (incf index))))) + (if (constant-p arg) + (let ((idx (constant-index arg)) + (opcode (instruction-opcode instruction))) + ;;(sys::%format t "constant ~A ~A index-size ~A index ~A~%" (type-of arg) idx (constant-index-size arg) index) + (if (or (<= 178 opcode 187) + (= opcode 189) + (= opcode 192) + (= opcode 193)) + (let ((idx (u2 idx))) + (setf (svref bytes index) (car idx) + (svref bytes (1+ index)) (cadr idx)) + (incf index 2)) + (progn + (setf (svref bytes index) idx) + (incf index)))) + (progn + (setf (svref bytes index) arg) + (incf index))))))) + (sys::%format t "~%~%~%BYTES ~S~%~%~%" bytes) (values bytes labels stack-map-table)))) -(defun ends-basic-block-p (opcode) - (or (branch-p opcode) - (>= 172 opcode 177))) ;;return variants +(defun unconditional-jump-p (opcode) + (= opcode 167)) (defstruct exception "Exception handler information. @@ -1234,17 +1274,13 @@ (,c (method-ensure-code ,method)) (*pool* (class-file-constants ,class-file)) (*code* (code-code ,c)) - (*code-locals* (code-computed-locals ,c)) - (*code-stack* (code-computed-stack ,c)) (*registers-allocated* (code-max-locals ,c)) (*register* (code-current-local ,c)) (*current-code-attribute* ,c)) , at body (setf (code-code ,c) *code* (code-current-local ,c) *register* - (code-max-locals ,c) *registers-allocated* - (code-computed-locals ,c) *code-locals* - (code-computed-stack ,c) *code-stack*)) + (code-max-locals ,c) *registers-allocated*)) (when *current-code-attribute* (restore-code-specials *current-code-attribute*))))) Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp ============================================================================== --- branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp (original) +++ branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Fri Oct 29 20:15:58 2010 @@ -61,6 +61,16 @@ (declare (ignorable instruction)) , at body)))) +(defun record-jump-to-label (label) + "Records a jump to a label appearing further down in the code." + ;;TODO: check that multiple jumps are compatible + (setf (get label 'jump-target-p) + t + (get label '*code-locals*) + *code-locals* + (get label '*code-stack*) + *code-stack*)) + ;; name number size stack-effect (nil if unknown) (define-opcode nop 0 1 0) (define-opcode aconst_null 1 1 1 (smf-push :null)) @@ -125,7 +135,6 @@ (defun iaf-store-effect (arg) (let ((t1 (smf-pop))) - (sys::%format t "iaf-store ~S~%" (list arg t1)) (smf-set arg t1) (when (> arg 0) (let ((t2 (smf-get (1- arg)))) @@ -260,7 +269,6 @@ (define-opcode ixor 130 1 -1 (smf-popn 2) (smf-push :int)) (define-opcode lxor 131 1 -2 (smf-popn 4) (smf-push :long)) (define-opcode iinc 132 3 0 - (sys::%format t "AAAAAAAAAAAA ~A~%" (instruction-args instruction)) (smf-set (car (instruction-args instruction)) :int)) (define-opcode i2l 133 1 1 (smf-pop) (smf-push :long)) (define-opcode i2f 134 1 0 (smf-pop) (smf-push :float)) @@ -282,12 +290,24 @@ (define-opcode fcmpg 150 1 -1 (smf-popn 2) (smf-push :int)) (define-opcode dcmpl 151 1 -3 (smf-popn 4) (smf-push :int)) (define-opcode dcmpg 152 1 -3 (smf-popn 4) (smf-push :int)) -(define-opcode ifeq 153 3 -1 (smf-pop)) -(define-opcode ifne 154 3 -1 (smf-pop)) -(define-opcode iflt 155 3 -1 (smf-pop)) -(define-opcode ifge 156 3 -1 (smf-pop)) -(define-opcode ifgt 157 3 -1 (smf-pop)) -(define-opcode ifle 158 3 -1 (smf-pop)) +(define-opcode ifeq 153 3 -1 + (smf-pop) + (record-jump-to-label (first (instruction-args instruction)))) +(define-opcode ifne 154 3 -1 + (smf-pop) + (record-jump-to-label (first (instruction-args instruction)))) +(define-opcode iflt 155 3 -1 + (smf-pop) + (record-jump-to-label (first (instruction-args instruction)))) +(define-opcode ifge 156 3 -1 + (smf-pop) + (record-jump-to-label (first (instruction-args instruction)))) +(define-opcode ifgt 157 3 -1 + (smf-pop) + (record-jump-to-label (first (instruction-args instruction)))) +(define-opcode ifle 158 3 -1 + (smf-pop) + (record-jump-to-label (first (instruction-args instruction)))) (define-opcode if_icmpeq 159 3 -2 (smf-popn 2)) (define-opcode if_icmpne 160 3 -2 (smf-popn 2)) (define-opcode if_icmplt 161 3 -2 (smf-popn 2)) @@ -296,7 +316,8 @@ (define-opcode if_icmple 164 3 -2 (smf-popn 2)) (define-opcode if_acmpeq 165 3 -2 (smf-popn 2)) (define-opcode if_acmpne 166 3 -2 (smf-popn 2)) -(define-opcode goto 167 3 0) +(define-opcode goto 167 3 0 + (record-jump-to-label (first (instruction-args instruction)))) ;;(define-opcode jsr 168 3 1) Don't use these 2 opcodes: deprecated ;;(define-opcode ret 169 2 0) their use results in JVM verifier errors (define-opcode tableswitch 170 0 nil (smf-pop)) @@ -308,30 +329,50 @@ (define-opcode areturn 176 1 -1 (smf-pop)) (define-opcode return 177 1 0) (define-opcode getstatic 178 3 1 - (sys::%format t "GETSTATIC ~A~%" (third (instruction-args instruction))) - ;;TODO!!! - (smf-push (third (instruction-args instruction)))) + (let ((field-type + (constant-name/type-type + (constant-member-ref-name/type (first (instruction-args instruction)))))) + (smf-push field-type))) (define-opcode putstatic 179 3 -1 - (sys::%format t "PUTSTATIC ~A~%" (third (instruction-args instruction))) - (smf-popt (third (instruction-args instruction)))) + (let ((field-type + (constant-name/type-type + (constant-member-ref-name/type (first (instruction-args instruction)))))) + (smf-popt field-type))) (define-opcode getfield 180 3 0 (smf-pop) - (smf-push (third (instruction-args instruction)))) + (let ((field-type + (constant-name/type-type + (constant-member-ref-name/type (first (instruction-args instruction)))))) + (smf-push field-type))) (define-opcode putfield 181 3 -2 - (smf-popt (third (instruction-args instruction))) + (let ((field-type + (constant-name/type-type + (constant-member-ref-name/type (first (instruction-args instruction)))))) + (smf-popt field-type)) (smf-pop)) (define-opcode invokevirtual 182 3 nil - (smf-popt (third (instruction-args instruction))) - (smf-pop) - (smf-push (third (instruction-args instruction)))) + (let ((method-return-and-arg-types + (constant-name/type-type + (constant-member-ref-name/type (first (instruction-args instruction)))))) + ;;(sys::%format t "invokevirtual ~S~%" method-return-and-arg-types) + (map nil #'smf-popt (cdr method-return-and-arg-types)) + (smf-pop) + (smf-push (car method-return-and-arg-types)))) (define-opcode invokespecial 183 3 nil - (smf-popt (third (instruction-args instruction))) - (smf-pop) - (smf-push (third (instruction-args instruction)))) + (let ((method-return-and-arg-types + (constant-name/type-type + (constant-member-ref-name/type (first (instruction-args instruction)))))) + ;;(sys::%format t "invokespecial ~S~%" method-return-and-arg-types) + (map nil #'smf-popt (cdr method-return-and-arg-types)) + (smf-pop) + (smf-push (car method-return-and-arg-types)))) (define-opcode invokestatic 184 3 nil - (sys::%format t "invokestatic ~S~%" (instruction-args instruction)) - (smf-popt (third (instruction-args instruction))) - (smf-push (third (instruction-args instruction)))) + (let ((method-return-and-arg-types + (constant-name/type-type + (constant-member-ref-name/type (first (instruction-args instruction)))))) + ;;(sys::%format t "invokestatic ~S~%" method-return-and-arg-types) + (map nil #'smf-popt (cdr method-return-and-arg-types)) + (smf-push (car method-return-and-arg-types)))) (define-opcode invokeinterface 185 5 nil (smf-popt (third (instruction-args instruction))) (smf-pop) @@ -365,7 +406,15 @@ (define-opcode ifnonnull 199 3 nil (smf-pop)) (define-opcode goto_w 200 5 nil) ;; (define-opcode jsr_w 201 5 nil) Don't use: deprecated -(define-opcode label 202 0 0) ;; virtual: does not exist in the JVM +(define-opcode label 202 0 0 ;; virtual: does not exist in the JVM + (if (get (first (instruction-args instruction)) 'jump-target-p) + ;;This label is the target of a jump emitted earlier + (setf *code-locals* + (get (first (instruction-args instruction)) '*code-locals*) + *code-stack* + (get (first (instruction-args instruction)) '*code-stack*)) + ;;Else simulate a jump to self to store locals and stack + (record-jump-to-label (first (instruction-args instruction))))) ;; (define-opcode push-value 203 nil 1) ;; (define-opcode store-value 204 nil -1) (define-opcode clear-values 205 0 0) ;; virtual: does not exist in the JVM @@ -410,6 +459,8 @@ pos *code-locals*))) (defun smf-set (pos type) + (when (null type) + (sys::%format t "smf-set null! pos ~A ~S~%" pos 42 #+nil(subseq (sys::backtrace-as-list) 2 10))) (if (< pos (length *code-locals*)) (setf (nth pos *code-locals*) type) (progn @@ -423,12 +474,12 @@ (push :top *code-stack))) (defun smf-pop () - ;(sys::%format t "smf-pop ~A~%" *code-stack*) (pop *code-stack*)) (defun smf-popt (type) - (declare (ignore type)) ;TODO - (pop *code-stack*)) + (pop *code-stack*) + (when (or (eq type :long) (eq type :double)) ;TODO + (pop *code-stack*))) (defun smf-popn (n) (dotimes (i n) @@ -465,8 +516,6 @@ (remove :wide-prefix args))))) (when (memq :wide-prefix args) (setf (inst-wide inst) t)) - (setf (instruction-input-locals inst) *code-locals*) - (setf (instruction-input-stack inst) *code-stack*) inst)) (defun print-instruction (instruction) @@ -522,18 +571,18 @@ (eq (car instr) 'QUOTE) (symbolp (cadr instr))) (setf instr (opcode-number (cadr instr)))) - (let ((instruction (gensym))) - `(let ((,instruction - ,(if (fixnump instr) - `(%%emit ,instr , at args) - `(%emit ,instr , at args)))) - ;(sys::%format t "EMIT ~S ~S~%" ',instr ',args) - (funcall (opcode-effect-function (instruction-opcode ,instruction)) - ,instruction) - (setf (instruction-output-locals ,instruction) *code-locals*) - (setf (instruction-output-stack ,instruction) *code-stack*) - ,instruction))) - + (if (fixnump instr) + `(%%emit ,instr , at args) + `(%emit ,instr , at args))) + +(defun simulate-instruction-effect (instruction) + (setf (instruction-input-locals instruction) *code-locals*) + (setf (instruction-input-stack instruction) *code-stack*) + (funcall (opcode-effect-function (instruction-opcode instruction)) + instruction) + (setf (instruction-output-locals instruction) *code-locals*) + (setf (instruction-output-stack instruction) *code-stack*) + instruction) ;; Helper routines @@ -619,9 +668,8 @@ (list (inst 'aload (car (instruction-args instruction))) (inst 'aconst_null) - (inst 'putfield (u2 (constant-index - (pool-field +lisp-thread+ "_values" - +lisp-object-array+)))))) + (inst 'putfield (pool-field +lisp-thread+ "_values" + +lisp-object-array+)))) (vector-push-extend instruction vector))) (t (vector-push-extend instruction vector))))))) From vvoutilainen at common-lisp.net Sat Oct 30 17:53:48 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sat, 30 Oct 2010 13:53:48 -0400 Subject: [armedbear-cvs] r12985 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sat Oct 30 13:53:45 2010 New Revision: 12985 Log: Add WILD-INFERIORS support for DIRECTORY. Modified: trunk/abcl/src/org/armedbear/lisp/directory.lisp Modified: trunk/abcl/src/org/armedbear/lisp/directory.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/directory.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/directory.lisp Sat Oct 30 13:53:45 2010 @@ -41,32 +41,53 @@ :type nil :version nil))) -(defun list-directories-with-wildcards (pathname) +(defun wild-inferiors-p (component) + (eq component :wild-inferiors)) + +(defun list-directories-with-wildcards (pathname + &optional (wild-inferiors-found nil)) (let* ((directory (pathname-directory pathname)) + (first-wild-inferior (and (not wild-inferiors-found) + (position-if #'wild-inferiors-p directory))) (first-wild (position-if #'wild-p directory)) - (wild (when first-wild (nthcdr first-wild directory))) - (non-wild (if first-wild + (wild (when (or first-wild-inferior first-wild) + (nthcdr (or first-wild-inferior first-wild) directory))) + (non-wild (if (or first-wild-inferior first-wild) (nbutlast directory - (- (length directory) first-wild)) - directory)) + (- (length directory) + (or first-wild-inferior first-wild))) + directory)) (newpath (make-pathname :directory non-wild :name nil :type nil :defaults pathname)) (entries (list-directory newpath))) - (if (not wild) - entries - (mapcan (lambda (entry) - (let* ((pathname (pathname entry)) - (directory (pathname-directory pathname)) - (rest-wild (cdr wild))) - (unless (pathname-name pathname) - (when (pathname-match-p (first (last directory)) - (if (eql (car wild) :wild) "*" (car wild))) - (when rest-wild - (setf directory (nconc directory rest-wild))) - (list-directories-with-wildcards - (make-pathname :directory directory - :defaults newpath)))))) - entries)))) + (if (not (or wild wild-inferiors-found)) + entries + (let ((inferior-entries (when (or wild-inferiors-found first-wild-inferior) entries))) + (nconc + (mapcan (lambda (entry) + (when (pathname-match-p (pathname entry) pathname) + (list entry))) + inferior-entries) + (mapcan (lambda (entry) + (let* ((pathname (pathname entry)) + (directory (pathname-directory pathname)) + (rest-wild (cdr wild))) + (unless (pathname-name pathname) + (when (pathname-match-p (first (last directory)) + (cond ((eql (car wild) :wild) + "*") + ((eql (car wild) :wild-inferiors) + "*") + (wild + (car wild)) + (t ""))) + (when rest-wild + (setf directory (nconc directory rest-wild))) + (list-directories-with-wildcards + (make-pathname :directory directory + :defaults newpath) + (or first-wild-inferior wild-inferiors-found)))))) + entries)))))) (defun directory (pathspec &key) From mevenson at common-lisp.net Sun Oct 31 08:40:31 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 31 Oct 2010 04:40:31 -0400 Subject: [armedbear-cvs] r12986 - in trunk/abcl: doc/asdf src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun Oct 31 04:40:27 2010 New Revision: 12986 Log: Upgrade to ASDF-2.010.1. Modified: trunk/abcl/doc/asdf/asdf.texinfo trunk/abcl/src/org/armedbear/lisp/asdf.lisp Modified: trunk/abcl/doc/asdf/asdf.texinfo ============================================================================== --- trunk/abcl/doc/asdf/asdf.texinfo (original) +++ trunk/abcl/doc/asdf/asdf.texinfo Sun Oct 31 04:40:27 2010 @@ -65,7 +65,7 @@ @titlepage - at title asdf: another system definition facility + at title ASDF: Another System Definition Facility @c The following two commands start the copyright page. @page @@ -206,7 +206,10 @@ Hopefully, ASDF 2 will soon be bundled with every Common Lisp implementation, and you can load it that way. - +If it is not, see @pxref{Loading ASDF,,Loading an otherwise installed ASDF} below. +if you are using the latest version of your Lisp vendor's software, +you may also send a bug report to your Lisp vendor and complain about +their failing to provide ASDF. @section Checking whether ASDF is loaded @@ -239,7 +242,7 @@ then you're using an old version of ASDF (from before 1.635). If it returns @code{NIL} then ASDF is not installed. -If you are running a version older than 2.000, +If you are running a version older than 2.008, we recommend that you load a newer ASDF using the method below. @@ -551,7 +554,8 @@ (asdf:load-system :@var{foo}) @end example -On some implementations (namely ABCL, Clozure CL, CMUCL, ECL and SBCL), +On some implementations (namely recent versions of +ABCL, Clozure CL, CLISP, CMUCL, ECL, SBCL and SCL), ASDF hooks into the @code{CL:REQUIRE} facility and you can just use: @@ -565,6 +569,19 @@ we recommend that you upgrade to ASDF 2. @xref{Loading ASDF,,Loading an otherwise installed ASDF}. +Note the name of a system is specified as a string or a symbol, +typically a keyword. +If a symbol (including a keyword), its name is taken and lowercased. +The name must be a suitable value for the @code{:name} initarg +to @code{make-pathname} in whatever filesystem the system is to be found. +The lower-casing-symbols behaviour is unconventional, +but was selected after some consideration. +Observations suggest that the type of systems we want to support +either have lowercase as customary case (unix, mac, windows) +or silently convert lowercase to uppercase (lpns), +so this makes more sense than attempting to use @code{:case :common}, +which is reported not to work on some implementations + @section Other Operations @@ -719,16 +736,24 @@ @lisp (defsystem "foo" :version "1.0" - :components ((:module "foo" :components ((:file "bar") (:file"baz") - (:file "quux")) - :perform (compile-op :after (op c) - (do-something c)) - :explain (compile-op :after (op c) - (explain-something c))) - (:file "blah"))) - at end lisp + :components ((:module "mod" + :components ((:file "bar") + (:file"baz") + (:file "quux")) + :perform (compile-op :after (op c) + (do-something c)) + :explain (compile-op :after (op c) + (explain-something c))) + (:file "blah"))) + at end lisp + +The @code{:module} component named @code{"mod"} is a collection of three files, +which will be located in a subdirectory of the main code directory named + at file{mod} (this location can be overridden; see the discussion of the + at code{:pathname} option in @ref{The defsystem grammar}). -The method-form tokens need explaining: essentially, this part: +The method-form tokens provide a shorthand for defining methods on +particular components. This part @lisp :perform (compile-op :after (op c) @@ -746,31 +771,58 @@ (explain-something c)) @end lisp -where @code{...} is the component in question; -note that although this also supports @code{:before} methods, -they may not do what you want them to --- -a @code{:before} method on perform @code{((op compile-op) (c (eql ...)))} -will run after all the dependencies and sub-components have been processed, -but before the component in question has been compiled. +where @code{...} is the component in question. +In this case @code{...} would expand to something like + + at lisp +(find-component (find-system "foo") "mod") + at end lisp + +For more details on the syntax of such forms, see @ref{The defsystem +grammar}. +For more details on what these methods do, @pxref{Operations} in + at ref{The object model of ASDF}. + + at c The following plunge into the weeds is not appropriate in this + at c location. [2010/10/03:rpg] + at c note that although this also supports @code{:before} methods, + at c they may not do what you want them to --- + at c a @code{:before} method on perform @code{((op compile-op) (c (eql ...)))} + at c will run after all the dependencies and sub-components have been processed, + at c but before the component in question has been compiled. @node The defsystem grammar, Other code in .asd files, A more involved example, Defining systems with defsystem @comment node-name, next, previous, up @section The defsystem grammar + at c FIXME: @var typesetting not consistently used here. We should either expand + at c its use to everywhere, or we should kill it everywhere. + + @example -system-definition := ( defsystem system-designator @var{option}* ) +system-definition := ( defsystem system-designator @var{system-option}* ) -option := :components component-list +system-option := :defsystem-depends-on system-list + | module-option + | option + +module-option := :components component-list + | :serial [ t | nil ] + | :if-component-dep-fails component-dep-fail-option + +option := | :pathname pathname-specifier - | :default-component-class + | :default-component-class class-name | :perform method-form | :explain method-form | :output-files method-form | :operation-done-p method-form | :depends-on ( @var{dependency-def}* ) - | :serial [ t | nil ] | :in-order-to ( @var{dependency}+ ) + +system-list := ( @var{simple-component-name}* ) + component-list := ( @var{component-def}* ) component-def := ( component-type simple-component-name @var{option}* ) @@ -796,8 +848,12 @@ method-form := (operation-name qual lambda-list @&rest body) qual := method qualifier + +component-dep-fail-option := :fail | :try-next | :ignore @end example + + @subsection Component names Component names (@code{simple-component-name}) @@ -811,6 +867,14 @@ the current package @code{my-system-asd} can be specified as @code{:my-component-type}, or @code{my-component-type}. + at subsection Defsystem depends on + +The @code{:defsystem-depends-on} option to @code{defsystem} allows the +programmer to specify another ASDF-defined system or set of systems that +must be loaded @emph{before} the system definition is processed. +Typically this is used to load an ASDF extension that is used in the +system definition. + @subsection Pathname specifiers @cindex pathname specifiers @@ -880,7 +944,7 @@ parsing component names as strings specifying paths with directories, and the cumbersome @code{#.(make-pathname ...)} syntax had to be used. -Note that when specifying pathname objects, +Note that when specifying pathname objects, ASDF does not do any special interpretation of the pathname influenced by the component type, unlike the procedure for pathname-specifying strings. @@ -892,7 +956,7 @@ @subsection Warning about logical pathnames - at cindex logical pathnames + at cindex logical pathnames We recommend that you not use logical pathnames in your asdf system definitions at this point, @@ -916,7 +980,7 @@ The advantage of this is that you can define yourself what translations you want to use with the logical pathname facility. The disadvantage is that if you do not define such translations, any -system that uses logical pathnames will be have differently under +system that uses logical pathnames will behave differently under asdf-output-translations than other systems you use. If you wish to use logical pathnames you will have to configure the @@ -929,7 +993,7 @@ @cindex serial dependencies If the @code{:serial t} option is specified for a module, -ASDF will add dependencies for each each child component, +ASDF will add dependencies for each child component, on all the children textually preceding it. This is done as if by @code{:depends-on}. @@ -993,6 +1057,13 @@ 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. + +For more information about this option, @pxref{Pre-defined subclasses of component}. + @node Other code in .asd files, , The defsystem grammar, Defining systems with defsystem @section Other code in .asd files @@ -1451,15 +1522,6 @@ the top component in that system. This is detailed elsewhere. @xref{Defining systems with defsystem}. -The answer to the frequently asked question -``how do I create a system definition -where all the source files have a @file{.cl} extension'' -is thus - - at lisp -(defmethod source-file-type ((c cl-source-file) (s (eql (find-system 'my-sys)))) - "cl") - at end lisp @subsubsection properties @@ -1671,11 +1733,14 @@ (at the time that the configuration is initialized) as well as @code{:directory} entries for @file{$XDG_DATA_DIRS/common-lisp/systems/} and @code{:tree} entries for @file{$XDG_DATA_DIRS/common-lisp/source/}. +For instance, SBCL will include directories for its contribs +when it can find them; it will look for them where SBCL was installed, +or at the location specified by the @code{SBCL_HOME} environment variable. @end enumerate -Each of these configuration is specified as a SEXP -in a trival domain-specific language (defined below). +Each of these configurations is specified as an s-expression +in a trivial domain-specific language (defined below). Additionally, a more shell-friendly syntax is available for the environment variable (defined yet below). @@ -1704,14 +1769,14 @@ instead of the XDG base directory specification, we try to use folder configuration from the registry regarding @code{Common AppData} and similar directories. -However, support querying the Windows registry is limited as of ASDF 2, +However, support for querying the Windows registry is limited as of ASDF 2, and on many implementations, we may fall back to always using the defaults without consulting the registry. Patches welcome. @section Backward Compatibility -For backward compatibility as well as for a practical backdoor for hackers, +For backward compatibility as well as to provide a practical backdoor for hackers, ASDF will first search for @code{.asd} files in the directories specified in @code{asdf:*central-registry*} before it searches in the source registry above. @@ -1725,10 +1790,10 @@ @section Configuration DSL -Here is the grammar of the SEXP DSL for source-registry configuration: +Here is the grammar of the s-expression (SEXP) DSL for source-registry configuration: @example -;; A configuration is single SEXP starting with keyword :source-registry +;; A configuration is a single SEXP starting with keyword :source-registry ;; followed by a list of directives. CONFIGURATION := (:source-registry DIRECTIVE ...) @@ -1750,6 +1815,8 @@ (:exclude PATTERN ...) | ;; augment the defaults for exclusion patterns (:also-exclude PATTERN ...) | + ;; Note that the scope of a an exclude pattern specification is + ;; the rest of the current configuration expression or file. ;; splice the parsed contents of another config file (:include REGULAR-FILE-PATHNAME-DESIGNATOR) | @@ -1757,6 +1824,29 @@ ;; This directive specifies that some default must be spliced. :default-registry +REGULAR-FILE-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ;; interpreted as a file +DIRECTORY-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ;; interpreted as a directory name + +PATHNAME-DESIGNATOR := + NULL | ;; Special: skip this entry. + ABSOLUTE-COMPONENT-DESIGNATOR | + (ABSOLUTE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...) + +ABSOLUTE-COMPONENT-DESIGNATOR := + STRING | ;; namestring (better be absolute or bust, directory assumed where applicable) + PATHNAME | ;; pathname (better be an absolute path, or bust) + :HOME | ;; designates the user-homedir-pathname ~/ + :USER-CACHE | ;; designates the default location for the user cache + :SYSTEM-CACHE ;; designates the default location for the system cache + +RELATIVE-COMPONENT-DESIGNATOR := + STRING | ;; namestring (directory assumed where applicable) + PATHNAME | ;; pathname + :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.32.30-linux-x86-64 + :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl + :UID | ;; current UID -- not available on Windows + :USER ;; current USER name -- NOT IMPLEMENTED(!) + PATTERN := a string without wildcards, that will be matched exactly against the name of a any subdirectory in the directory component of a path. e.g. @code{"_darcs"} will match @file{#p"/foo/bar/_darcs/src/bar.asd"} @@ -1767,11 +1857,10 @@ once contained: @example (:source-registry - (:tree "/home/fare/cl/") + (:tree (:home "cl")) ;; will expand to e.g. "/home/joeluser/cl/" :inherit-configuration) @end example - @section Configuration Directories Configuration directories consist in files each contains @@ -1834,6 +1923,7 @@ @section Search Algorithm + at vindex *default-source-registry-exclusions* In case that isn't clear, the semantics of the configuration is that when searching for a system of a given name, @@ -1896,8 +1986,10 @@ @defun clear-source-registry undoes any source registry configuration and clears any cache for the search algorithm. - You might want to call that before you - dump an image that would be resumed with a different configuration, + You might want to call this function + (or better, @code{clear-configuration}) + before you dump an image that would be resumed + with a different configuration, and return an empty configuration. Note that this does not include clearing information about systems defined in the current image, only about @@ -1909,6 +2001,15 @@ If not, initialize it with the given @var{PARAMETER}. @end defun +Every time you use ASDF's @code{find-system}, or +anything that uses it (such as @code{operate}, @code{load-system}, etc.), + at code{ensure-source-registry} is called with parameter NIL, +which the first time around causes your configuration to be read. +If you change a configuration file, +you need to explicitly @code{initialize-source-registry} again, +or maybe simply to @code{clear-source-registry} (or @code{clear-configuration}) +which will cause the initialization to happen next time around. + @section Future @@ -2189,15 +2290,13 @@ PATHNAME | ;; pathname (better be an absolute directory or bust) :HOME | ;; designates the user-homedir-pathname ~/ :USER-CACHE | ;; designates the default location for the user cache - :SYSTEM-CACHE | ;; designates the default location for the system cache - :CURRENT-DIRECTORY ;; the current directory + :SYSTEM-CACHE ;; designates the default location for the system cache RELATIVE-COMPONENT-DESIGNATOR := STRING | ;; namestring, directory is assumed. If the last component, /**/*.* is added PATHNAME | ;; pathname unless last component, directory is assumed. :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.32.30-linux-x86-64 :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl - :CURRENT-DIRECTORY | ;; all components of the current directory, without the :absolute :UID | ;; current UID -- not available on Windows :USER ;; current USER name -- NOT IMPLEMENTED(!) @@ -2380,8 +2479,10 @@ @defun clear-output-translations undoes any output translation configuration and clears any cache for the mapping algorithm. - You might want to call that before you - dump an image that would be resumed with a different configuration, + You might want to call this function + (or better, @code{clear-configuration}) + before you dump an image that would be resumed + with a different configuration, and return an empty configuration. Note that this does not include clearing information about systems defined in the current image, only about @@ -2399,6 +2500,15 @@ (calls @code{ensure-output-translations} for the translations). @end defun +Every time you use ASDF's @code{output-files}, or +anything that uses it (that may compile, such as @code{operate}, @code{perform}, etc.), + at code{ensure-output-translations} is called with parameter NIL, +which the first time around causes your configuration to be read. +If you change a configuration file, +you need to explicitly @code{initialize-output-translations} again, +or maybe @code{clear-output-translations} (or @code{clear-configuration}), +which will cause the initialization to happen next time around. + @section Credits for output translations @@ -2494,13 +2604,45 @@ @defun system-source-directory system-designator -ASDF does not provide a turnkey solution for locating data (or other -miscellaneous) files that are distributed together with the source code -of a system. Programmers can use @code{system-source-directory} to find -such files. Returns a pathname object. The @var{system-designator} may -be a string, symbol, or ASDF system object. +ASDF does not provide a turnkey solution for locating +data (or other miscellaneous) files +that are distributed together with the source code of a system. +Programmers can use @code{system-source-directory} to find such files. +Returns a pathname object. +The @var{system-designator} may be a string, symbol, or ASDF system object. @end defun + at defun clear-system system-designator + +It is sometimes useful to force recompilation of a previously loaded system. +In these cases, it may be useful to @code{(asdf:clear-system :foo)} +to remove the system from the table of currently loaded systems; +the next time the system @code{foo} or one that depends on it is re-loaded, + at code{foo} will then be loaded again. +Alternatively, you could touch @code{foo.asd} or +remove the corresponding fasls from the output file cache. +(It was once conceived that one should provide +a list of systems the recompilation of which to force +as the @code{:force} keyword argument to @code{load-system}; +but this has never worked, and though the feature was fixed in ASDF 2.000, +it remains @code{cerror}'ed out as nobody ever used it.) + +Note that this does not and cannot by itself undo the previous loading +of the system. Common Lisp has no provision for such an operation, +and its reliance on irreversible side-effects to global datastructures +makes such a thing impossible in the general case. +If the software being re-loaded is not conceived with hot upgrade in mind, +this re-loading may cause many errors, warnings or subtle silent problems, +as packages, generic function signatures, structures, types, macros, constants, etc. +are being redefined incompatibly. +It is up to the user to make sure that reloading is possible and has the desired effect. +In some cases, extreme measures such as recursively deleting packages, +unregistering symbols, defining methods on @code{update-instance-for-redefined-class} +and much more are necessary for reloading to happen smoothly. +ASDF itself goes through notable pains to make such a hot upgrade possible +with respect to its own code, and what it does is ridiculously complex; +look at the beginning of @file{asdf.lisp} to see what it does. + at end defun @node Getting the latest version, FAQ, Miscellaneous additional functionality, Top @comment node-name, next, previous, up @@ -2534,7 +2676,7 @@ ASDF bugs are tracked on launchpad: @url{https://launchpad.net/asdf}. -If you're unsure about whether something is a bug, of for general discussion, +If you're unsure about whether something is a bug, or for general discussion, use the @url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list} @@ -2756,7 +2898,7 @@ towards the latest version for everyone. - at subsection Pitfalls of ASDF 2 + at subsection Pitfalls of the transition to ASDF 2 The main pitfalls in upgrading to ASDF 2 seem to be related to the output translation mechanism. @@ -2783,6 +2925,12 @@ @pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}. But thou shall not load ABL on top of ASDF 2. + at end itemize + +Other issues include the following: + + at itemize + @item ASDF pathname designators are now specified in places where they were unspecified, and a few small adjustments have to be made to some non-portable defsystems. @@ -2793,12 +2941,6 @@ moreover when evaluation is desired @code{#.} must be used, where it wasn't necessary in the toplevel @code{:pathname} argument. - at end itemize - -Other issues include the following: - - at itemize - @item There is a slight performance bug, notably on SBCL, when initially searching for @file{asd} files, @@ -2817,8 +2959,24 @@ @item On Windows, only LispWorks supports proper default configuration pathnames based on the Windows registry. -Other implementations make do. -Windows support is largely untested, so please help report and fix bugs. +Other implementations make do with environment variables. +Windows support is somewhat less tested than Unix support. +Please help report and fix bugs. + + at item +The mechanism by which one customizes a system so that Lisp files +may use a different extension from the default @file{.lisp} has changed. +Previously, the pathname for a component was lazily computed when operating on a system, +and you would + at code{(defmethod source-file-type ((component cl-source-file) (system (eql (find-system 'foo)))) + (declare (ignorable component system)) "cl")}. +Now, the pathname for a component is eagerly computed when defining the system, +and instead you will @code{(defclass my-cl-source-file (cl-source-file) ((type :iniform "cl")))} +and use @code{:default-component-class my-cl-source-file} as argument to @code{defsystem}, +as detailed in a @pxref{FAQ,How do I create a system definition where all the source files have a .cl extension?} below. + + at findex source-file-type + @end itemize @@ -2839,7 +2997,7 @@ @subsection ``I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?'' Starting with current candidate releases of ASDF 2, -it should always be a good time to upgrade to a recent version of ASDF. +it should always be a good time to upgrade to a recent ASDF. You may consult with the maintainer for which specific version they recommend, but the latest RELEASE should be correct. We trust you to thoroughly test it with your implementation before you release it. @@ -2850,7 +3008,7 @@ @itemize @item -If ASDF isn't installed yet, then @code{(require :asdf)} +If ASDF isn't loaded yet, then @code{(require :asdf)} should load the version of ASDF that is bundled with your system. You may have it load some other version configured by the user, if you allow such configuration. @@ -2858,7 +3016,7 @@ @item If your system provides a mechanism to hook into @code{CL:REQUIRE}, then it would be nice to add ASDF to this hook the same way that -ABCL, CCL, CMUCL, ECL and SBCL do it. +ABCL, CCL, CLISP, CMUCL, ECL, SBCL and SCL do it. @item You may, like SBCL, have ASDF be implicitly used to require systems @@ -2876,8 +3034,9 @@ 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, -or you may otherwise rename the system and its file to e.g. +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}. Indeed, if you made @file{asdf.asd} a magic system, @@ -3086,6 +3245,39 @@ or as a name component plus optional dot-separated type component (if the component class doesn't specifies a pathname type). + at subsection How do I create a system definition where all the source files have a .cl extension? + +First, create a new @code{cl-source-file} subclass that provides an +initform for the @code{type} slot: + + at lisp +(defclass my-cl-source-file (cl-source-file) + ((type :initform "cl"))) + at end lisp + +To support both ASDF 1 and ASDF 2, +you may omit the above @code{type} slot definition and instead define: + + at lisp +(defmethod source-file-type ((f my-cl-source-file) (m module)) + (declare (ignorable f m)) + "cl") + at end lisp + +Then make your system use this subclass in preference to the standard +one: + + at lisp +(defsystem my-cl-system + :default-component-class my-cl-source-file + .... +) + at end lisp + +We assume that these definitions are loaded into a package that uses + at code{ASDF}. + + @node TODO list, Inspiration, FAQ, Top @comment node-name, next, previous, up @@ -3263,7 +3455,7 @@ The defsystem 4 proposal tends to look more at the external features, whereas this one centres on a protocol for system introspection. - at section kmp's ``The Description of Large Systems'', MIT AI Memu 801 + at section kmp's ``The Description of Large Systems'', MIT AI Memo 801 Available in updated-for-CL form on the web at @url{http://nhplace.com/kent/Papers/Large-Systems.html} Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Sun Oct 31 04:40:27 2010 @@ -47,73 +47,66 @@ #+xcvb (module ()) -(cl:in-package :cl) -(defpackage :asdf-bootstrap (:use :cl)) -(in-package :asdf-bootstrap) +(cl:in-package :cl-user) + +#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this -;; Implementation-dependent tweaks (eval-when (:compile-toplevel :load-toplevel :execute) - ;; (declaim (optimize (speed 2) (debug 2) (safety 3)) ; NO: rely on the implementation defaults. + ;;; make package if it doesn't exist yet. + ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. + (unless (find-package :asdf) + (make-package :asdf :use '(:cl))) + ;;; Implementation-dependent tweaks + ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults. #+allegro (setf excl::*autoload-package-name-alist* (remove "asdf" excl::*autoload-package-name-alist* :test 'equalp :key 'car)) - #+ecl (require :cmp) - #+gcl - (eval-when (:compile-toplevel :load-toplevel) - (defpackage :asdf-utilities (:use :cl)) - (defpackage :asdf (:use :cl :asdf-utilities)))) + #+ecl (require :cmp)) + +(in-package :asdf) ;;;; Create packages in a way that is compatible with hot-upgrade. ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 ;;;; See more at the end of the file. (eval-when (:load-toplevel :compile-toplevel :execute) - (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate - (subseq "VERSION:2.004" (1+ (length "VERSION")))) ; NB: same as 2.111. - (existing-asdf (find-package :asdf)) - (vername '#:*asdf-version*) - (versym (and existing-asdf - (find-symbol (string vername) existing-asdf))) - (existing-version (and versym (boundp versym) (symbol-value versym))) + (defvar *asdf-version* nil) + (defvar *upgraded-p* nil) + (let* ((asdf-version "2.010.1") ;; bump this version when you modify this file. Same as 2.147 + (existing-asdf (fboundp 'find-system)) + (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) (unless (and existing-asdf already-there) - #-gcl (when existing-asdf - (format *trace-output* + (format *error-output* "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%" existing-version asdf-version)) (labels - ((rename-away (package) - (loop :with name = (package-name package) - :for i :from 1 :for new = (format nil "~A.~D" name i) - :unless (find-package new) :do - (rename-package-name package name new))) - (rename-package-name (package old new) - (let* ((old-names (cons (package-name package) - (package-nicknames package))) - (new-names (subst new old old-names :test 'equal)) - (new-name (car new-names)) - (new-nicknames (cdr new-names))) - (rename-package package new-name new-nicknames))) + ((unlink-package (package) + (let ((u (find-package package))) + (when u + (ensure-unintern u + (loop :for s :being :each :present-symbol :in u :collect s)) + (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 - (remove-if - #'null - (mapcar #'find-package (cons name nicknames))) - :from-end t))) - (cond - (previous - ;; do away with packages with conflicting (nick)names - (map () #'rename-away (cdr previous)) - ;; reuse previous package with same name - (let ((p (car previous))) + (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))))) + p) + (t + (make-package name :nicknames nicknames :use use)))))) (find-sym (symbol package) (find-symbol (string symbol) package)) (intern* (symbol package) @@ -122,9 +115,16 @@ (let ((sym (find-sym symbol package))) (when sym (unexport sym package) - (unintern sym package)))) + (unintern sym package) + sym))) (ensure-unintern (package symbols) - (dolist (sym symbols) (remove-symbol sym package))) + (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-sym sym p)) + (unintern removed p))))) (ensure-shadow (package symbols) (shadow symbols package)) (ensure-use (package use) @@ -138,15 +138,26 @@ :for sym = (find-sym name package) :when sym :do (fmakunbound sym))) (ensure-export (package export) - (let ((syms (loop :for x :in export :collect - (intern* x package)))) - (do-external-symbols (sym package) - (unless (member sym syms) - (remove-symbol sym package))) - (dolist (sym syms) - (export sym package)))) + (let ((formerly-exported-symbols nil) + (bothly-exported-symbols nil) + (newly-exported-symbols nil)) + (loop :for sym :being :each :external-symbol :in package :do + (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 'string-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-sym 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 fmakunbound shadow export) - (let ((p (ensure-exists name nicknames use))) + (let* ((p (ensure-exists name nicknames use))) (ensure-unintern p unintern) (ensure-shadow p shadow) (ensure-export p export) @@ -161,41 +172,14 @@ :unintern ',(append #-(or gcl ecl) redefined-functions unintern) :fmakunbound ',(append fmakunbound)))) (pkgdcl - :asdf-utilities - :nicknames (#:asdf-extensions) - :use (#:common-lisp) - :unintern (#:split #:make-collector) - :export - (#:absolute-pathname-p - #:aif - #:appendf - #:asdf-message - #:coerce-name - #:directory-pathname-p - #:ends-with - #:ensure-directory-pathname - #:getenv - #:get-uid - #:length=n-p - #:merge-pathnames* - #:pathname-directory-pathname - #:read-file-forms - #:remove-keys - #:remove-keyword - #:resolve-symlinks - #:split-string - #:component-name-to-pathname-components - #:split-name-type - #:system-registered-p - #:truenamize - #:while-collecting)) - (pkgdcl :asdf - :use (:common-lisp :asdf-utilities) + :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only. + :use (:common-lisp) :redefined-functions (#:perform #:explain #:output-files #:operation-done-p #:perform-with-restarts #:component-relative-pathname - #:system-source-file #:operate #:find-component) + #:system-source-file #:operate #:find-component #:find-system + #:apply-output-translations #:translate-pathname* #:resolve-location) :unintern (#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector) @@ -207,7 +191,7 @@ :export (#:defsystem #:oos #:operate #:find-system #:run-shell-command #:system-definition-pathname #:find-component ; miscellaneous - #:compile-system #:load-system #:test-system + #:compile-system #:load-system #:test-system #:clear-system #:compile-op #:load-op #:load-source-op #:test-op #:operation ; operations @@ -215,7 +199,7 @@ #:version ; metaphorically sort-of an operation #:version-satisfies - #:input-files #:output-files #:perform ; operation methods + #:input-files #:output-files #:output-file #:perform ; operation methods #:operation-done-p #:explain #:component #:source-file @@ -254,6 +238,7 @@ #:operation-on-warnings #:operation-on-failure + #:component-visited-p ;;#:*component-parent-pathname* #:*system-definition-search-functions* #:*central-registry* ; variables @@ -283,6 +268,7 @@ #:coerce-entry-to-directory #:remove-entry-from-registry + #:clear-configuration #:initialize-output-translations #:disable-output-translations #:clear-output-translations @@ -291,28 +277,44 @@ #:compile-file* #:compile-file-pathname* #:enable-asdf-binary-locations-compatibility - #:*default-source-registries* #:initialize-source-registry #:compute-source-registry #:clear-source-registry #:ensure-source-registry - #:process-source-registry))) - (let* ((version (intern* vername :asdf)) - (upvar (intern* '#:*upgraded-p* :asdf)) - (upval0 (and (boundp upvar) (symbol-value upvar))) - (upval1 (if existing-version (cons existing-version upval0) upval0))) - (eval `(progn - (defparameter ,version ,asdf-version) - (defparameter ,upvar ',upval1)))))))) + #:process-source-registry + #:system-registered-p + #:asdf-message -(in-package :asdf) + ;; Utilities + #:absolute-pathname-p + ;; #:aif #:it + ;; #:appendf + #:coerce-name + #:directory-pathname-p + ;; #:ends-with + #:ensure-directory-pathname + #:getenv + ;; #:get-uid + ;; #:length=n-p + #:merge-pathnames* + #:pathname-directory-pathname + #:read-file-forms + ;; #:remove-keys + ;; #:remove-keyword + #:resolve-symlinks + #:split-string + #:component-name-to-pathname-components + #:split-name-type + #:subdirectories + #:truenamize + #:while-collecting))) + (setf *asdf-version* asdf-version + *upgraded-p* (if existing-version + (cons existing-version *upgraded-p*) + *upgraded-p*)))))) ;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687 -#+gcl -(eval-when (:compile-toplevel :load-toplevel) - (defvar *asdf-version* nil) - (defvar *upgraded-p* nil)) (when *upgraded-p* #+ecl (when (find-class 'compile-op nil) @@ -326,9 +328,11 @@ '(defmethod update-instance-for-redefined-class :after ((m module) added deleted plist &key) (declare (ignorable deleted plist)) - (format *trace-output* "Updating ~A~%" m) + (when *asdf-verbose* (format *trace-output* "Updating ~A~%" m)) (when (member 'components-by-name added) - (compute-module-components-by-name m)))))) + (compute-module-components-by-name m)) + (when (and (typep m 'system) (member 'source-file added)) + (%set-system-source-file (probe-asd (component-name m) (component-pathname m)) m)))))) ;;;; ------------------------------------------------------------------------- ;;;; User-visible parameters @@ -342,17 +346,18 @@ (defvar *resolve-symlinks* t "Determine whether or not ASDF resolves symlinks when defining systems. -Defaults to `t`.") +Defaults to T.") -(defvar *compile-file-warnings-behaviour* :warn - "How should ASDF react if it encounters a warning when compiling a -file? Valid values are :error, :warn, and :ignore.") - -(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :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.") +(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.") + +(defvar *compile-file-failure-behaviour* + (or #+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.") (defvar *verbose-out* nil) @@ -371,53 +376,64 @@ ;;;; ------------------------------------------------------------------------- ;;;; ASDF Interface, in terms of generic functions. -(defmacro defgeneric* (name formals &rest options) - `(progn - #+(or gcl ecl) (fmakunbound ',name) - (defgeneric ,name ,formals , at options))) +(macrolet + ((defdef (def* def) + `(defmacro ,def* (name formals &rest rest) + `(progn + #+(or ecl gcl) (fmakunbound ',name) + ,(when (and #+ecl (symbolp name)) + `(declaim (notinline ,name))) ; fails for setf functions on ecl + (,',def ,name ,formals , at rest))))) + (defdef defgeneric* defgeneric) + (defdef defun* defun)) +(defgeneric* find-system (system &optional error-p)) (defgeneric* perform-with-restarts (operation component)) (defgeneric* perform (operation component)) (defgeneric* operation-done-p (operation component)) (defgeneric* explain (operation component)) (defgeneric* output-files (operation component)) (defgeneric* input-files (operation component)) -(defgeneric component-operation-time (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) +(defgeneric* component-system (component) (:documentation "Find the top-level system containing COMPONENT")) -(defgeneric component-pathname (component) +(defgeneric* component-pathname (component) (:documentation "Extracts the pathname applicable for a particular component.")) -(defgeneric component-relative-pathname (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)) +(defgeneric* component-property (component property)) -(defgeneric (setf component-property) (new-value component property)) +(defgeneric* (setf component-property) (new-value component property)) -(defgeneric version-satisfies (component version)) +(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.")) -(defgeneric source-file-type (component system)) +(defgeneric* source-file-type (component system)) -(defgeneric operation-ancestor (operation) +(defgeneric* operation-ancestor (operation) (:documentation "Recursively chase the operation's parent pointer until we get to the head of the tree")) -(defgeneric component-visited-p (operation component) +(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 @@ -430,7 +446,7 @@ data value is NIL, the combination had been explored, but no operations needed to be performed.")) -(defgeneric visit-component (operation component data) +(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 @@ -438,13 +454,16 @@ 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.")) +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.")) + -(defgeneric (setf visiting-component) (new-value operation component)) +(defgeneric* (setf visiting-component) (new-value operation component)) -(defgeneric component-visiting-p (operation component)) +(defgeneric* component-visiting-p (operation component)) -(defgeneric component-depends-on (operation component) +(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: @@ -461,9 +480,9 @@ should usually append the results of CALL-NEXT-METHOD to the list.")) -(defgeneric component-self-dependencies (operation component)) +(defgeneric* component-self-dependencies (operation component)) -(defgeneric traverse (operation component) +(defgeneric* traverse (operation component) (:documentation "Generate and return a plan for performing OPERATION on COMPONENT. @@ -496,13 +515,13 @@ (defmacro aif (test then &optional else) `(let ((it ,test)) (if it ,then ,else))) -(defun pathname-directory-pathname (pathname) +(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 merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) +(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS. Also, if either argument is NIL, then the other argument is returned unmodified." @@ -511,7 +530,18 @@ (let* ((specified (pathname specified)) (defaults (pathname defaults)) (directory (pathname-directory specified)) - #-sbcl (directory (if (stringp directory) `(:absolute ,directory) directory)) + (directory + (cond + #-(or sbcl cmu scl) + ((stringp directory) `(:absolute ,directory) directory) + #+gcl + ((and (consp directory) (not (member (first directory) '(:absolute :relative)))) + `(:relative , at directory)) + ((or (null directory) + (and (consp directory) (member (first directory) '(:absolute :relative)))) + directory) + (t + (error "Unrecognized directory component ~S in pathname ~S" directory specified)))) (name (or (pathname-name specified) (pathname-name defaults))) (type (or (pathname-type specified) (pathname-type defaults))) (version (or (pathname-version specified) (pathname-version defaults)))) @@ -520,7 +550,7 @@ (unspecific-handler (p) (if (typep p 'logical-pathname) #'ununspecific #'identity))) (multiple-value-bind (host device directory unspecific-handler) - (#-gcl ecase #+gcl case (first directory) + (ecase (first directory) ((nil) (values (pathname-host defaults) (pathname-device defaults) @@ -537,13 +567,6 @@ (if (pathname-directory defaults) (append (pathname-directory defaults) (cdr directory)) directory) - (unspecific-handler defaults))) - #+gcl - (t - (assert (stringp (first directory))) - (values (pathname-host defaults) - (pathname-device defaults) - (append (pathname-directory defaults) directory) (unspecific-handler defaults)))) (make-pathname :host host :device device :directory directory :name (funcall unspecific-handler name) @@ -556,17 +579,17 @@ (define-modify-macro orf (&rest args) or "or a flag") -(defun first-char (s) +(defun* first-char (s) (and (stringp s) (plusp (length s)) (char s 0))) -(defun last-char (s) +(defun* last-char (s) (and (stringp s) (plusp (length s)) (char s (1- (length s))))) -(defun asdf-message (format-string &rest format-args) +(defun* asdf-message (format-string &rest format-args) (declare (dynamic-extent format-args)) (apply #'format *verbose-out* format-string format-args)) -(defun split-string (string &key max (separator '(#\Space #\Tab))) +(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, @@ -586,7 +609,7 @@ (incf words) (setf end start)))))) -(defun split-name-type (filename) +(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. @@ -598,7 +621,7 @@ (values filename unspecific) (values name type))))) -(defun component-name-to-pathname-components (s &optional force-directory) +(defun* component-name-to-pathname-components (s &key force-directory force-relative) "Splits the path string S, returning three values: A flag that is either :absolute or :relative, indicating how the rest of the values are to be interpreted. @@ -615,12 +638,17 @@ e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames." (check-type s string) + (when (find #\: s) + (error "a portable ASDF pathname designator cannot include a #\: character: ~S" s)) (let* ((components (split-string s :separator "/")) (last-comp (car (last components)))) (multiple-value-bind (relative components) (if (equal (first components) "") (if (equal (first-char s) #\/) - (values :absolute (cdr components)) + (progn + (when force-relative + (error "absolute pathname designator not allowed: ~S" s)) + (values :absolute (cdr components))) (values :relative nil)) (values :relative components)) (setf components (remove "" components :test #'equal)) @@ -632,38 +660,30 @@ (t (values relative (butlast components) last-comp)))))) -(defun remove-keys (key-names args) +(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) +(defun* remove-keyword (key args) (loop :for (k v) :on args :by #'cddr :unless (eq k key) :append (list k v))) -(defun getenv (x) - #+abcl - (ext:getenv x) - #+sbcl - (sb-ext:posix-getenv x) - #+clozure - (ccl:getenv x) - #+clisp - (ext:getenv x) - #+cmu - (cdr (assoc (intern x :keyword) ext:*environment-list*)) - #+lispworks - (lispworks:environment-variable x) - #+allegro - (sys:getenv x) - #+gcl - (system:getenv x) - #+ecl - (si:getenv x)) +(defun* getenv (x) + (#+abcl ext:getenv + #+allegro sys:getenv + #+clisp ext:getenv + #+clozure ccl:getenv + #+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=))) + #+ecl si:getenv + #+gcl system:getenv + #+lispworks lispworks:environment-variable + #+sbcl sb-ext:posix-getenv + x)) -(defun directory-pathname-p (pathname) +(defun* directory-pathname-p (pathname) "Does PATHNAME represent a directory? A directory-pathname is a pathname _without_ a filename. The three @@ -672,13 +692,16 @@ Note that this does _not_ check to see that PATHNAME points to an actually-existing directory." - (flet ((check-one (x) - (member x '(nil :unspecific "") :test 'equal))) - (and (check-one (pathname-name pathname)) - (check-one (pathname-type pathname)) - t))) + (when pathname + (let ((pathname (pathname pathname))) + (flet ((check-one (x) + (member x '(nil :unspecific "") :test 'equal))) + (and (not (wild-pathname-p pathname)) + (check-one (pathname-name pathname)) + (check-one (pathname-type pathname)) + t))))) -(defun ensure-directory-pathname (pathspec) +(defun* ensure-directory-pathname (pathspec) "Converts the non-wild pathname designator PATHSPEC to directory form." (cond ((stringp pathspec) @@ -686,7 +709,7 @@ ((not (pathnamep pathspec)) (error "Invalid pathname designator ~S" pathspec)) ((wild-pathname-p pathspec) - (error "Can't reliably convert wild pathnames.")) + (error "Can't reliably convert wild pathname ~S" pathspec)) ((directory-pathname-p pathspec) pathspec) (t @@ -696,10 +719,10 @@ :name nil :type nil :version nil :defaults pathspec)))) -(defun absolute-pathname-p (pathspec) - (eq :absolute (car (pathname-directory (pathname pathspec))))) +(defun* absolute-pathname-p (pathspec) + (and pathspec (eq :absolute (car (pathname-directory (pathname pathspec)))))) -(defun length=n-p (x n) ;is it that (= (length x) n) ? +(defun* length=n-p (x n) ;is it that (= (length x) n) ? (check-type n (integer 0 *)) (loop :for l = x :then (cdr l) @@ -708,14 +731,14 @@ ((zerop i) (return (null l))) ((not (consp l)) (return nil))))) -(defun ends-with (s suffix) +(defun* ends-with (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) +(defun* read-file-forms (file) (with-open-file (in file) (loop :with eof = (list nil) :for form = (read in nil eof) @@ -724,43 +747,56 @@ #-(and (or win32 windows mswindows mingw32) (not cygwin)) (progn -#+clisp (defun get-uid () (posix:uid)) -#+sbcl (defun get-uid () (sb-unix:unix-getuid)) -#+cmu (defun get-uid () (unix:unix-getuid)) -#+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601) - '(ffi:clines "#include " "#include ")) -#+ecl (defun get-uid () - #.(cl:if (cl:< ext:+ecl-version-number+ 100601) - '(ffi:c-inline () () :int "getuid()" :one-liner t) - '(ext::getuid))) -#+allegro (defun get-uid () (excl.osi:getuid)) -#-(or cmu sbcl clisp allegro ecl) -(defun get-uid () - (let ((uid-string - (with-output-to-string (*verbose-out*) - (run-shell-command "id -ur")))) - (with-input-from-string (stream uid-string) - (read-line stream) - (handler-case (parse-integer (read-line stream)) - (error () (error "Unable to find out user ID"))))))) + #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601) + '(ffi:clines "#include " "#include ")) + (defun* get-uid () + #+allegro (excl.osi:getuid) + #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid") + :for f = (ignore-errors (read-from-string s)) + :when f :return (funcall f)) + #+(or cmu scl) (unix:unix-getuid) + #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601) + '(ffi:c-inline () () :int "getuid()" :one-liner t) + '(ext::getuid)) + #+sbcl (sb-unix:unix-getuid) + #-(or allegro clisp cmu ecl sbcl scl) + (let ((uid-string + (with-output-to-string (*verbose-out*) + (run-shell-command "id -ur")))) + (with-input-from-string (stream uid-string) + (read-line stream) + (handler-case (parse-integer (read-line stream)) + (error () (error "Unable to find out user ID"))))))) -(defun pathname-root (pathname) +(defun* pathname-root (pathname) (make-pathname :host (pathname-host pathname) :device (pathname-device pathname) :directory '(:absolute) :name nil :type nil :version nil)) -(defun truenamize (p) +(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 ecl sbcl scl) '(probe-file p) + #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(ignore-errors (,it p))) + '(ignore-errors (truename p))))))) + +(defun* truenamize (p) "Resolve as much of a pathname as possible" (block nil (when (typep p 'logical-pathname) (return p)) (let* ((p (merge-pathnames* p)) (directory (pathname-directory p))) (when (typep p 'logical-pathname) (return p)) - (ignore-errors (return (truename p))) - #-sbcl (when (stringp directory) (return p)) + (let ((found (probe-file* p))) + (when found (return found))) + #-(or sbcl cmu) (when (stringp directory) (return p)) (when (not (eq :absolute (car directory))) (return p)) - (let ((sofar (ignore-errors (truename (pathname-root p))))) + (let ((sofar (probe-file* (pathname-root p)))) (unless sofar (return p)) (flet ((solution (directories) (merge-pathnames* @@ -772,35 +808,34 @@ sofar))) (loop :for component :in (cdr directory) :for rest :on (cdr directory) - :for more = (ignore-errors - (truename - (merge-pathnames* - (make-pathname :directory `(:relative ,component)) - sofar))) :do + :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 resolve-symlinks (path) +(defun* resolve-symlinks (path) #-allegro (truenamize path) #+allegro (excl:pathname-resolve-symbolic-links path)) -(defun default-directory () +(defun* default-directory () (truenamize (pathname-directory-pathname *default-pathname-defaults*))) -(defun lispize-pathname (input-file) +(defun* lispize-pathname (input-file) (make-pathname :type "lisp" :defaults input-file)) (defparameter *wild-path* (make-pathname :directory '(:relative :wild-inferiors) :name :wild :type :wild :version :wild)) -(defun wilden (path) +(defun* wilden (path) (merge-pathnames* *wild-path* path)) -(defun directorize-pathname-host-device (pathname) +(defun* directorize-pathname-host-device (pathname) (let* ((root (pathname-root pathname)) (wild-root (wilden root)) (absolute-pathname (merge-pathnames* pathname root)) @@ -813,7 +848,7 @@ (eql x separator))) root-namestring))) (multiple-value-bind (relative path filename) - (component-name-to-pathname-components root-string t) + (component-name-to-pathname-components root-string :force-directory t) (declare (ignore relative filename)) (let ((new-base (make-pathname :defaults root @@ -837,7 +872,8 @@ error-name error-pathname error-condition duplicate-names-name error-component error-operation - module-components module-components-by-name) + module-components module-components-by-name + circular-dependency-components) (ftype (function (t t) t) (setf module-components-by-name))) @@ -856,7 +892,9 @@ (error-name c) (error-pathname c) (error-condition c))))) (define-condition circular-dependency (system-definition-error) - ((components :initarg :components :reader circular-dependency-components))) + ((components :initarg :components :reader circular-dependency-components)) + (:report (lambda (c s) + (format s "~@" (circular-dependency-components c))))) (define-condition duplicate-names (system-definition-error) ((name :initarg :name :reader duplicate-names-name)) @@ -892,11 +930,29 @@ ((name :accessor component-name :initarg :name :documentation "Component name: designator for a string composed of portable pathname characters") (version :accessor component-version :initarg :version) - (in-order-to :initform nil :initarg :in-order-to - :accessor component-in-order-to) ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to? + ;; POIU is a parallel (multi-process build) extension of ASDF. See + ;; http://www.cliki.net/poiu (load-dependencies :accessor component-load-dependencies :initform nil) - ;; XXX crap name, but it's an official API name! + ;; In the ASDF object model, dependencies exist between *actions* + ;; (an action is a pair of operation and component). They are represented + ;; alists of operations to dependencies (other actions) in each component. + ;; There are two kinds of dependencies, each stored in its own slot: + ;; in-order-to and do-first dependencies. These two kinds are related to + ;; the fact that some actions modify the filesystem, + ;; whereas other actions modify the current image, and + ;; this implies a difference in how to interpret timestamps. + ;; in-order-to dependencies will trigger re-performing the action + ;; when the timestamp of some dependency + ;; makes the timestamp of current action out-of-date; + ;; do-first dependencies do not trigger such re-performing. + ;; Therefore, a FASL must be recompiled if it is obsoleted + ;; by any of its FASL dependencies (in-order-to); but + ;; it needn't be recompiled just because one of these dependencies + ;; hasn't yet been loaded in the current image (do-first). + ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52! + (in-order-to :initform nil :initarg :in-order-to + :accessor component-in-order-to) (do-first :initform nil :initarg :do-first :accessor component-do-first) ;; methods defined using the "inline" style inside a defsystem form: @@ -915,7 +971,7 @@ (properties :accessor component-properties :initarg :properties :initform nil))) -(defun component-find-path (component) +(defun* component-find-path (component) (reverse (loop :for c = component :then (component-parent c) :while c :collect (component-name c)))) @@ -931,26 +987,24 @@ (format s "~@<~A, required by ~A~@:>" (call-next-method c nil) (missing-required-by c))) -(defun sysdef-error (format &rest arguments) +(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 "~@" + (format s "~@" (missing-requires c) (when (missing-parent c) (component-name (missing-parent c))))) (defmethod print-object ((c missing-component-of-version) s) - (format s "~@" - (missing-requires c) - (missing-version c) - (when (missing-parent c) - (component-name (missing-parent c))))) + (format s "~@" + (missing-requires c) + (missing-version c) + (when (missing-parent c) + (component-name (missing-parent c))))) (defmethod component-system ((component component)) (aif (component-parent component) @@ -959,7 +1013,7 @@ (defvar *default-component-class* 'cl-source-file) -(defun compute-module-components-by-name (module) +(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) @@ -989,7 +1043,7 @@ :initarg :default-component-class :accessor module-default-component-class))) -(defun component-parent-pathname (component) +(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 @@ -1006,7 +1060,8 @@ (component-relative-pathname component) (pathname-directory-pathname (component-parent-pathname component))))) (unless (or (null pathname) (absolute-pathname-p pathname)) - (error "Invalid relative pathname ~S for component ~S" pathname component)) + (error "Invalid relative pathname ~S for component ~S" + pathname (component-find-path component))) (setf (slot-value component 'absolute-pathname) pathname) pathname))) @@ -1030,7 +1085,8 @@ (licence :accessor system-licence :initarg :licence :accessor system-license :initarg :license) (source-file :reader system-source-file :initarg :source-file - :writer %set-system-source-file))) + :writer %set-system-source-file) + (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) ;;;; ------------------------------------------------------------------------- ;;;; version-satisfies @@ -1057,7 +1113,7 @@ ;;;; ------------------------------------------------------------------------- ;;;; Finding systems -(defun make-defined-systems-table () +(defun* make-defined-systems-table () (make-hash-table :test 'equal)) (defvar *defined-systems* (make-defined-systems-table) @@ -1067,17 +1123,17 @@ system definition was last updated, and the second element of which is a system object.") -(defun coerce-name (name) +(defun* coerce-name (name) (typecase name (component (component-name name)) (symbol (string-downcase (symbol-name name))) (string name) (t (sysdef-error "~@" name)))) -(defun system-registered-p (name) +(defun* system-registered-p (name) (gethash (coerce-name name) *defined-systems*)) -(defun clear-system (name) +(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 @@ -1088,7 +1144,7 @@ ;; that the system was loaded at some point. (setf (gethash (coerce-name name) *defined-systems*) nil)) -(defun map-systems (fn) +(defun* map-systems (fn) "Apply FN to each defined system. FN should be a function of one argument. It will be @@ -1106,7 +1162,7 @@ (defparameter *system-definition-search-functions* '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf)) -(defun system-definition-pathname (system) +(defun* system-definition-pathname (system) (let ((system-name (coerce-name system))) (or (some (lambda (x) (funcall x system-name)) @@ -1130,7 +1186,7 @@ Going forward, we recommend new users should be using the source-registry. ") -(defun probe-asd (name defaults) +(defun* probe-asd (name defaults) (block nil (when (directory-pathname-p defaults) (let ((file @@ -1151,7 +1207,7 @@ (when target (return (pathname target))))))))) -(defun sysdef-central-registry-search (system) +(defun* sysdef-central-registry-search (system) (let ((name (coerce-name system)) (to-remove nil) (to-replace nil)) @@ -1169,8 +1225,7 @@ (let* ((*print-circle* nil) (message (format nil - "~@" + "~@" system dir defaults))) (error message)) (remove-entry-from-registry () @@ -1193,7 +1248,7 @@ (list new) (subseq *central-registry* (1+ position)))))))))) -(defun make-temporary-package () +(defun* make-temporary-package () (flet ((try (counter) (ignore-errors (make-package (format nil "~A~D" :asdf counter) @@ -1202,7 +1257,7 @@ (package (try counter) (try counter))) (package package)))) -(defun safe-file-write-date (pathname) +(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 @@ -1213,15 +1268,17 @@ ;; (or should we treat the case in a different, special way?) (or (and pathname (probe-file pathname) (file-write-date pathname)) (progn - (when pathname + (when (and pathname *asdf-verbose*) (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero." pathname)) 0))) -(defun find-system (name &optional (error-p t)) +(defmethod find-system (name &optional (error-p t)) + (find-system (coerce-name name) error-p)) + +(defmethod find-system ((name string) &optional (error-p t)) (catch 'find-system - (let* ((name (coerce-name name)) - (in-memory (system-registered-p name)) + (let* ((in-memory (system-registered-p name)) (on-disk (system-definition-pathname name))) (when (and on-disk (or (not in-memory) @@ -1240,28 +1297,34 @@ (load on-disk))) (delete-package package)))) (let ((in-memory (system-registered-p name))) - (if in-memory - (progn (when on-disk (setf (car in-memory) - (safe-file-write-date on-disk))) - (cdr in-memory)) - (when error-p (error 'missing-component :requires name))))))) + (cond + (in-memory + (when on-disk + (setf (car in-memory) (safe-file-write-date on-disk))) + (cdr in-memory)) + (error-p + (error 'missing-component :requires name))))))) -(defun register-system (name system) +(defun* register-system (name system) (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) (setf (gethash (coerce-name name) *defined-systems*) (cons (get-universal-time) system))) -(defun sysdef-find-asdf (system) - (let ((name (coerce-name system))) - (when (equal name "asdf") - (let* ((registered (cdr (gethash name *defined-systems*))) - (asdf (or registered - (make-instance - 'system :name "asdf" - :source-file (or *compile-file-truename* *load-truename*))))) - (unless registered - (register-system "asdf" asdf)) - (throw 'find-system asdf))))) +(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) + (setf fallback (coerce-name fallback) + source-file (or source-file *compile-file-truename* *load-truename*) + requested (coerce-name requested)) + (when (equal requested fallback) + (let* ((registered (cdr (gethash fallback *defined-systems*))) + (system (or registered + (apply 'make-instance 'system + :name fallback :source-file source-file keys)))) + (unless registered + (register-system fallback system)) + (throw 'find-system system)))) + +(defun* sysdef-find-asdf (name) + (find-system-fallback name "asdf")) ;; :version *asdf-version* wouldn't be updated when ASDF is updated. ;;;; ------------------------------------------------------------------------- @@ -1317,14 +1380,14 @@ (declare (ignorable s)) (source-file-explicit-type component)) -(defun merge-component-name-type (name &key type defaults) +(defun* merge-component-name-type (name &key type 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 either (a) use absolute pathnames, or ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of - ;; ASDF-UTILITIES:MERGE-PATHNAMES* + ;; ASDF:MERGE-PATHNAMES* (etypecase name (pathname name) @@ -1332,7 +1395,8 @@ (merge-component-name-type (string-downcase name) :type type :defaults defaults)) (string (multiple-value-bind (relative path filename) - (component-name-to-pathname-components name (eq type :directory)) + (component-name-to-pathname-components name :force-directory (eq type :directory) + :force-relative t) (multiple-value-bind (name type) (cond ((or (eq type :directory) (null filename)) @@ -1369,7 +1433,7 @@ ;; including other systems we depend on. ;; (SYSTEM1 SYSTEM2 ... SYSTEMN) ;; to force systems named in a given list - ;; (but this feature never worked before ASDF 1.700 and is cerror'ed out.) + ;; However, but this feature never worked before ASDF 1.700 and is currently cerror'ed out. (forced :initform nil :initarg :force :accessor operation-forced) (original-initargs :initform nil :initarg :original-initargs :accessor operation-original-initargs) @@ -1389,7 +1453,7 @@ ;; empty method to disable initarg validity checking (values)) -(defun node-for (o c) +(defun* node-for (o c) (cons (class-name (class-of o)) c)) (defmethod operation-ancestor ((operation operation)) @@ -1398,7 +1462,7 @@ operation)) -(defun make-sub-operation (c o dep-c dep-o) +(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." @@ -1543,9 +1607,9 @@ "This dynamically-bound variable is used to force operations in recursive calls to traverse.") -(defgeneric do-traverse (operation component collect)) +(defgeneric* do-traverse (operation component collect)) -(defun %do-one-dep (operation c collect required-op required-c required-v) +(defun* %do-one-dep (operation c collect required-op required-c required-v) ;; collects a partial plan that results from performing required-op ;; on required-c, possibly with a required-vERSION (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c))) @@ -1561,9 +1625,9 @@ (op (make-sub-operation c operation dep-c required-op))) (do-traverse op dep-c collect))) -(defun do-one-dep (operation c collect required-op required-c required-v) - ;; this function is a thin, error-handling wrapper around - ;; %do-one-dep. Returns a partial plan per that function. +(defun* do-one-dep (operation c collect required-op required-c required-v) + ;; this function is a thin, error-handling wrapper around %do-one-dep. + ;; Collects a partial plan per that function. (loop (restart-case (return (%do-one-dep operation c collect @@ -1571,22 +1635,15 @@ (retry () :report (lambda (s) (format s "~@" - required-c)) + (component-find-path required-c))) :test (lambda (c) - #| - (print (list :c1 c (typep c 'missing-dependency))) - (when (typep c 'missing-dependency) - (print (list :c2 (missing-requires c) required-c - (equalp (missing-requires c) - required-c)))) - |# (or (null c) (and (typep c 'missing-dependency) (equalp (missing-requires c) required-c)))))))) -(defun do-dep (operation c collect op dep) +(defun* do-dep (operation c collect op dep) ;; type of arguments uncertain: ;; op seems to at least potentially be a symbol, rather than an operation ;; dep is a list of component names @@ -1625,7 +1682,9 @@ (error "Bad dependency ~a. Dependencies must be (:version ), (:feature [version]), or a name" d)))))) flag)))) -(defun do-collect (collect x) +(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) @@ -1710,10 +1769,10 @@ (do-collect collect (vector module-ops)) (do-collect collect (cons operation c))))) (setf (visiting-component operation c) nil))) - (visit-component operation c flag) + (visit-component operation c (when flag (incf *visit-count*))) flag)) -(defun flatten-tree (l) +(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. @@ -1740,12 +1799,12 @@ (mapcar #'coerce-name (operation-forced operation)))) (flatten-tree (while-collecting (collect) - (do-traverse operation c #'collect)))) + (let ((*visit-count* 0)) + (do-traverse operation c #'collect))))) (defmethod perform ((operation operation) (c source-file)) (sysdef-error - "~@" + "~@" (class-of operation) (class-of c))) (defmethod perform ((operation operation) (c module)) @@ -1753,7 +1812,10 @@ nil) (defmethod explain ((operation operation) (component component)) - (asdf-message "~&;;; ~A on ~A~%" operation component)) + (asdf-message "~&;;; ~A~%" (operation-description operation component))) + +(defmethod operation-description (operation component) + (format nil "~A on component ~S" (class-of operation) (component-find-path component))) ;;;; ------------------------------------------------------------------------- ;;;; compile-op @@ -1767,6 +1829,12 @@ (flags :initarg :flags :accessor compile-op-flags :initform #-ecl nil #+ecl '(:system-p t)))) +(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 perform :before ((operation compile-op) (c source-file)) (map nil #'ensure-directories-exist (output-files operation c))) @@ -1783,7 +1851,8 @@ (setf (gethash (type-of operation) (component-operation-times c)) (get-universal-time))) -(declaim (ftype (function ((or pathname string) &rest t &key &allow-other-keys) +(declaim (ftype (function ((or pathname string) + &rest t &key (:output-file t) &allow-other-keys) (values t t t)) compile-file*)) @@ -1792,7 +1861,9 @@ (defmethod perform ((operation compile-op) (c cl-source-file)) #-:broken-fasl-loader (let ((source-file (component-pathname c)) - (output-file (car (output-files operation 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) @@ -1835,6 +1906,9 @@ (declare (ignorable operation c)) nil) +(defmethod operation-description ((operation compile-op) component) + (declare (ignorable operation)) + (format nil "compiling component ~S" (component-find-path component))) ;;;; ------------------------------------------------------------------------- ;;;; load-op @@ -1844,11 +1918,11 @@ (defclass load-op (basic-load-op) ()) (defmethod perform ((o load-op) (c cl-source-file)) - #-ecl (mapcar #'load (input-files o c)) - #+ecl (loop :for i :in (input-files o c) - :unless (string= (pathname-type i) "fas") - :collect (let ((output (compile-file-pathname (lispize-pathname i)))) - (load output)))) + (map () #'load + #-ecl (input-files o c) + #+ecl (loop :for i :in (input-files o c) + :unless (string= (pathname-type i) "fas") + :collect (compile-file-pathname (lispize-pathname i))))) (defmethod perform-with-restarts (operation component) (perform operation component)) @@ -1911,6 +1985,11 @@ (cons (list 'compile-op (component-name c)) (call-next-method))) +(defmethod operation-description ((operation load-op) component) + (declare (ignorable operation)) + (format nil "loading component ~S" (component-find-path component))) + + ;;;; ------------------------------------------------------------------------- ;;;; load-source-op @@ -1949,6 +2028,10 @@ (component-property c 'last-loaded-as-source))) nil t)) +(defmethod operation-description ((operation load-source-op) component) + (declare (ignorable operation)) + (format nil "loading component ~S" (component-find-path component))) + ;;;; ------------------------------------------------------------------------- ;;;; test-op @@ -1998,21 +2081,19 @@ (retry () :report (lambda (s) - (format s "~@" - op component))) + (format s "~@" (operation-description op component)))) (accept () :report (lambda (s) - (format s "~@" - op component)) + (format s "~@" + (operation-description op component))) (setf (gethash (type-of op) (component-operation-times component)) (get-universal-time)) - (return))))))) - op)) + (return)))))) + (values op steps)))) -(defun oos (operation-class system &rest args &key force verbose version +(defun* oos (operation-class system &rest args &key force verbose version &allow-other-keys) (declare (ignore force verbose version)) (apply #'operate operation-class system args)) @@ -2042,37 +2123,40 @@ (setf (documentation 'operate 'function) operate-docstring)) -(defun load-system (system &rest args &key force verbose version +(defun* load-system (system &rest args &key force verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details." (declare (ignore force verbose version)) - (apply #'operate 'load-op system args)) + (apply #'operate 'load-op system args) + t) -(defun compile-system (system &rest args &key force verbose version +(defun* compile-system (system &rest args &key force verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE for details." (declare (ignore force verbose version)) - (apply #'operate 'compile-op system args)) + (apply #'operate 'compile-op system args) + t) -(defun test-system (system &rest args &key force verbose version +(defun* test-system (system &rest args &key force verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for details." (declare (ignore force verbose version)) - (apply #'operate 'test-op system args)) + (apply #'operate 'test-op system args) + t) ;;;; ------------------------------------------------------------------------- ;;;; Defsystem -(defun load-pathname () +(defun* load-pathname () (let ((pn (or *load-pathname* *compile-file-pathname*))) (if *resolve-symlinks* (and pn (resolve-symlinks pn)) pn))) -(defun determine-system-pathname (pathname pathname-supplied-p) +(defun* determine-system-pathname (pathname pathname-supplied-p) ;; The defsystem macro calls us to determine ;; the pathname of a system as follows: ;; 1. the one supplied, @@ -2081,14 +2165,14 @@ (let* ((file-pathname (load-pathname)) (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname)))) (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname)) - file-pathname + directory-pathname (default-directory)))) (defmacro defsystem (name &body options) (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system) defsystem-depends-on &allow-other-keys) options - (let ((component-options (remove-keys '(:defsystem-depends-on :class) options))) + (let ((component-options (remove-keys '(:class) options))) `(progn ;; system must be registered before we parse the body, otherwise ;; we recur when trying to find an existing system of the same name @@ -2112,7 +2196,7 @@ ,(determine-system-pathname pathname pathname-arg-p) ',component-options)))))) -(defun class-for-type (parent type) +(defun* class-for-type (parent type) (or (loop :for symbol :in (list (unless (keywordp type) type) (find-symbol (symbol-name type) *package*) @@ -2125,7 +2209,7 @@ (find-class *default-component-class*))) (sysdef-error "~@" type))) -(defun maybe-add-tree (tree op1 op2 c) +(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))) @@ -2140,7 +2224,7 @@ tree) (acons op1 (list (list op2 c)) tree)))) -(defun union-of-dependencies (&rest deps) +(defun* union-of-dependencies (&rest deps) (let ((new-tree nil)) (dolist (dep deps) (dolist (op-tree dep) @@ -2153,12 +2237,12 @@ (defvar *serial-depends-on* nil) -(defun sysdef-error-component (msg type name value) +(defun* sysdef-error-component (msg type name value) (sysdef-error (concatenate 'string msg "~&The value specified for ~(~A~) ~A is ~S") type name value)) -(defun check-component-input (type name weakly-depends-on +(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) @@ -2174,7 +2258,7 @@ (sysdef-error-component ":in-order-to must be NIL or a list of components." type name in-order-to))) -(defun %remove-component-inline-methods (component) +(defun* %remove-component-inline-methods (component) (dolist (name +asdf-methods+) (map () ;; this is inefficient as most of the stored @@ -2186,7 +2270,7 @@ ;; clear methods, then add the new ones (setf (component-inline-methods component) nil)) -(defun %define-component-inline-methods (ret rest) +(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) @@ -2200,11 +2284,11 @@ , at body)) (component-inline-methods ret))))))) -(defun %refresh-component-inline-methods (component rest) +(defun* %refresh-component-inline-methods (component rest) (%remove-component-inline-methods component) (%define-component-inline-methods component rest)) -(defun parse-component-form (parent options) +(defun* parse-component-form (parent options) (destructuring-bind (type name &rest rest &key ;; the following list of keywords is reproduced below in the @@ -2285,7 +2369,7 @@ ;;;; 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 -(defun run-shell-command (control-string &rest args) +(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." @@ -2357,7 +2441,7 @@ (defmethod system-source-file ((system-name symbol)) (system-source-file (find-system system-name))) -(defun system-source-directory (system-designator) +(defun* system-source-directory (system-designator) "Return a pathname object corresponding to the directory in which the system specification (.asd file) is located." @@ -2365,7 +2449,7 @@ :type nil :defaults (system-source-file system-designator))) -(defun relativize-directory (directory) +(defun* relativize-directory (directory) (cond ((stringp directory) (list :relative directory)) @@ -2374,13 +2458,13 @@ (t directory))) -(defun relativize-pathname-directory (pathspec) +(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) (merge-pathnames* (merge-component-name-type name :type type) (system-source-directory system))) @@ -2393,25 +2477,35 @@ ;;; Initially stolen from SLIME's SWANK, hacked since. (defparameter *implementation-features* - '(:allegro :lispworks :sbcl :clozure :digitool :cmu :clisp - :corman :cormanlisp :armedbear :gcl :ecl :scl)) + '((:acl :allegro) + (:lw :lispworks) + (:digitool) ; before clozure, so it won't get preempted by ccl + (:ccl :clozure) + (:corman :cormanlisp) + (:abcl :armedbear) + :sbcl :cmu :clisp :gcl :ecl :scl)) (defparameter *os-features* - '((:windows :mswindows :win32 :mingw32) + '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows (:solaris :sunos) - :linux ;; for GCL at least, must appear before :bsd. - :macosx :darwin :apple + (:linux :linux-target) ;; for GCL at least, must appear before :bsd. + (:macosx :darwin :darwin-target :apple) :freebsd :netbsd :openbsd :bsd :unix)) (defparameter *architecture-features* - '((:x86-64 :amd64 :x86_64 :x8664-target) - (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4) - :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc - :java-1.4 :java-1.5 :java-1.6 :java-1.7)) - + '((:amd64 :x86-64 :x86_64 :x8664-target) + (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target) + :hppa64 + :hppa + (:ppc64 :ppc64-target) + (:ppc32 :ppc32-target :ppc :powerpc) + :sparc64 + (:sparc32 :sparc) + (:arm :arm-target) + (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7))) -(defun lisp-version-string () +(defun* lisp-version-string () (let ((s (lisp-implementation-version))) (declare (ignorable s)) #+allegro (format nil @@ -2428,7 +2522,7 @@ (if (member :64bit *features*) "-64bit" "")) #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) #+clisp (subseq s 0 (position #\space s)) - #+clozure (format nil "~d.~d-fasl~d" + #+clozure (format nil "~d.~d-f~d" ; shorten for windows ccl::*openmcl-major-version* ccl::*openmcl-minor-version* (logand ccl::fasl-version #xFF)) @@ -2446,7 +2540,7 @@ #-(or allegro armedbear clisp clozure cmu cormanlisp digitool ecl gcl lispworks mcl sbcl scl) s)) -(defun first-feature (features) +(defun* first-feature (features) (labels ((fp (thing) (etypecase thing @@ -2462,10 +2556,10 @@ (loop :for f :in features :when (fp f) :return :it))) -(defun implementation-type () +(defun* implementation-type () (first-feature *implementation-features*)) -(defun implementation-identifier () +(defun* implementation-identifier () (labels ((maybe-warn (value fstring &rest args) (cond (value) @@ -2480,8 +2574,7 @@ "No architecture feature found in ~a." *architecture-features*)) (version (maybe-warn (lisp-version-string) - "Don't know how to get Lisp ~ - implementation version."))) + "Don't know how to get Lisp implementation version."))) (substitute-if #\_ (lambda (x) (find x " /:\\(){}[]$#`'\"")) (format nil "~(~@{~a~^-~}~)" lisp version os arch))))) @@ -2495,16 +2588,16 @@ #+(or unix cygwin) #\: #-(or unix cygwin) #\;) -(defun user-homedir () +(defun* user-homedir () (truename (user-homedir-pathname))) -(defun try-directory-subpath (x sub &key type) +(defun* try-directory-subpath (x sub &key type) (let* ((p (and x (ensure-directory-pathname x))) - (tp (and p (ignore-errors (truename p)))) + (tp (and p (probe-file* p))) (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p))) - (ts (and sp (ignore-errors (truename sp))))) + (ts (and sp (probe-file* sp)))) (and ts (values sp ts)))) -(defun user-configuration-directories () +(defun* user-configuration-directories () (remove-if #'null (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) @@ -2517,7 +2610,7 @@ ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData ,(try (getenv "APPDATA") "common-lisp/config/")) ,(try (user-homedir) ".config/common-lisp/"))))) -(defun system-configuration-directories () +(defun* system-configuration-directories () (remove-if #'null (append @@ -2527,21 +2620,20 @@ ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/")))) (list #p"/etc/common-lisp/")))) -(defun in-first-directory (dirs x) +(defun* in-first-directory (dirs x) (loop :for dir :in dirs - :thereis (and dir (ignore-errors - (truename (merge-pathnames* x (ensure-directory-pathname dir))))))) -(defun in-user-configuration-directory (x) + :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir)))))) +(defun* in-user-configuration-directory (x) (in-first-directory (user-configuration-directories) x)) -(defun in-system-configuration-directory (x) +(defun* in-system-configuration-directory (x) (in-first-directory (system-configuration-directories) x)) -(defun configuration-inheritance-directive-p (x) +(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 validate-configuration-form (form tag directive-validator +(defun* validate-configuration-form (form tag directive-validator &optional (description tag)) (unless (and (consp form) (eq (car form) tag)) (error "Error: Form doesn't specify ~A ~S~%" description form)) @@ -2556,16 +2648,16 @@ :inherit-configuration :ignore-inherited-configuration))) form) -(defun validate-configuration-file (file validator description) +(defun* validate-configuration-file (file validator description) (let ((forms (read-file-forms file))) (unless (length=n-p forms 1) (error "One and only one form allowed for ~A. Got: ~S~%" description forms)) (funcall validator (car forms)))) -(defun hidden-file-p (pathname) +(defun* hidden-file-p (pathname) (equal (first-char (pathname-name pathname)) #\.)) -(defun validate-configuration-directory (directory tag validator) +(defun* validate-configuration-directory (directory tag validator) (let ((files (sort (ignore-errors (remove-if 'hidden-file-p @@ -2603,10 +2695,10 @@ ;; with other users messing with such directories. *user-cache*) -(defun output-translations () +(defun* output-translations () (car *output-translations*)) -(defun (setf output-translations) (new-value) +(defun* (setf output-translations) (new-value) (setf *output-translations* (list (stable-sort (copy-list new-value) #'> @@ -2617,34 +2709,34 @@ (length (pathname-directory (car x))))))))) new-value) -(defun output-translations-initialized-p () +(defun* output-translations-initialized-p () (and *output-translations* t)) -(defun clear-output-translations () +(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." (setf *output-translations* '()) (values)) -(defparameter *wild-asd* - (make-pathname :directory '(:relative :wild-inferiors) - :name :wild :type "asd" :version :newest)) - - -(declaim (ftype (function (t &optional boolean) (or null pathname)) +(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)) + (values (or null pathname) &optional)) resolve-location)) -(defun resolve-relative-location-component (super x &optional wildenp) +(defun* resolve-relative-location-component (super x &key directory wilden) (let* ((r (etypecase x (pathname x) (string x) (cons - (let ((car (resolve-relative-location-component super (car x) nil))) + (return-from resolve-relative-location-component (if (null (cdr x)) - car - (let ((cdr (resolve-relative-location-component - (merge-pathnames* car super) (cdr x) wildenp))) + (resolve-relative-location-component + super (car x) :directory directory :wilden wilden) + (let* ((car (resolve-relative-location-component + super (car x) :directory t :wilden nil)) + (cdr (resolve-relative-location-component + (merge-pathnames* car super) (cdr x) + :directory directory :wilden wilden))) (merge-pathnames* cdr car))))) ((eql :default-directory) (relativize-pathname-directory (default-directory))) @@ -2652,56 +2744,62 @@ ((eql :implementation-type) (string-downcase (implementation-type))) #-(and (or win32 windows mswindows mingw32) (not cygwin)) ((eql :uid) (princ-to-string (get-uid))))) - (d (if (pathnamep x) r (ensure-directory-pathname r))) - (s (if (and wildenp (not (pathnamep x))) - (wilden d) - d))) + (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r))) + (s (if (or (pathnamep x) (not wilden)) d (wilden d)))) (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super)))) (error "pathname ~S is not relative to ~S" s super)) (merge-pathnames* s super))) -(defun resolve-absolute-location-component (x wildenp) +(defun* resolve-absolute-location-component (x &key directory wilden) (let* ((r (etypecase x (pathname x) - (string (ensure-directory-pathname x)) + (string (if directory (ensure-directory-pathname x) (parse-namestring x))) (cons - (let ((car (resolve-absolute-location-component (car x) nil))) + (return-from resolve-absolute-location-component (if (null (cdr x)) - car - (let ((cdr (resolve-relative-location-component - car (cdr x) wildenp))) - (merge-pathnames* cdr car))))) + (resolve-absolute-location-component + (car x) :directory directory :wilden wilden) + (let* ((car (resolve-absolute-location-component + (car x) :directory t :wilden nil)) + (cdr (resolve-relative-location-component + car (cdr x) :directory directory :wilden wilden))) + (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ? ((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 - (make-pathname :directory '(:relative)))) + (let ((p (make-pathname :directory '(:relative)))) + (if wilden (wilden p) p)))) ((eql :home) (user-homedir)) - ((eql :user-cache) (resolve-location *user-cache* nil)) - ((eql :system-cache) (resolve-location *system-cache* nil)) + ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil)) + ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil)) ((eql :default-directory) (default-directory)))) - (s (if (and wildenp (not (pathnamep x))) + (s (if (and wilden (not (pathnamep x))) (wilden r) r))) (unless (absolute-pathname-p s) (error "Not an absolute pathname ~S" s)) s)) -(defun resolve-location (x &optional wildenp) +(defun* resolve-location (x &key directory wilden) (if (atom x) - (resolve-absolute-location-component x wildenp) - (loop :with path = (resolve-absolute-location-component (car x) nil) + (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 (resolve-relative-location-component - path component (and wildenp (not morep)))) + path component :directory dir :wilden wild)) :finally (return path)))) -(defun location-designator-p (x) +(defun* location-designator-p (x) (flet ((componentp (c) (typep c '(or string pathname keyword)))) (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x))))) -(defun location-function-p (x) +(defun* location-function-p (x) (and (consp x) (length=n-p x 2) @@ -2711,11 +2809,11 @@ (cddr x) (length=n-p (second x) 2))))) -(defun validate-output-translations-directive (directive) +(defun* validate-output-translations-directive (directive) (unless (or (member directive '(:inherit-configuration :ignore-inherited-configuration - :enable-user-cache :disable-cache)) + :enable-user-cache :disable-cache nil)) (and (consp directive) (or (and (length=n-p directive 2) (or (and (eq (first directive) :include) @@ -2728,22 +2826,22 @@ (error "Invalid directive ~S~%" directive)) directive) -(defun validate-output-translations-form (form) +(defun* validate-output-translations-form (form) (validate-configuration-form form :output-translations 'validate-output-translations-directive "output translations")) -(defun validate-output-translations-file (file) +(defun* validate-output-translations-file (file) (validate-configuration-file file 'validate-output-translations-form "output translations")) -(defun validate-output-translations-directory (directory) +(defun* validate-output-translations-directory (directory) (validate-configuration-directory directory :output-translations 'validate-output-translations-directive)) -(defun parse-output-translations-string (string) +(defun* parse-output-translations-string (string) (cond ((or (null string) (equal string "")) '(:output-translations :inherit-configuration)) @@ -2788,36 +2886,36 @@ system-output-translations-pathname system-output-translations-directory-pathname)) -(defun wrapping-output-translations () +(defun* wrapping-output-translations () `(:output-translations ;; Some implementations have precompiled ASDF systems, ;; so we must disable translations for implementation paths. - #+sbcl (,(getenv "SBCL_HOME") ()) + #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ()))) #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system - #+clozure (,(wilden (truename #p"ccl:")) ()) ; not needed: no precompiled ASDF system + #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system ;; All-import, here is where we want user stuff to be: :inherit-configuration ;; These are for convenience, and can be overridden by the user: #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) - ;; If we want to enable the user cache by default, here would be the place: + ;; We enable the user cache by default, and here is the place we do: :enable-user-cache)) (defparameter *output-translations-file* #p"asdf-output-translations.conf") (defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/") -(defun user-output-translations-pathname () +(defun* user-output-translations-pathname () (in-user-configuration-directory *output-translations-file* )) -(defun system-output-translations-pathname () +(defun* system-output-translations-pathname () (in-system-configuration-directory *output-translations-file*)) -(defun user-output-translations-directory-pathname () +(defun* user-output-translations-directory-pathname () (in-user-configuration-directory *output-translations-directory*)) -(defun system-output-translations-directory-pathname () +(defun* system-output-translations-directory-pathname () (in-system-configuration-directory *output-translations-directory*)) -(defun environment-output-translations () +(defun* environment-output-translations () (getenv "ASDF_OUTPUT_TRANSLATIONS")) -(defgeneric process-output-translations (spec &key inherit collect)) +(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) @@ -2847,11 +2945,11 @@ (dolist (directive (cdr (validate-output-translations-form form))) (process-output-translations-directive directive :inherit inherit :collect collect))) -(defun inherit-output-translations (inherit &key 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) @@ -2860,7 +2958,7 @@ (process-output-translations-directive '(t t) :collect collect)) ((:inherit-configuration) (inherit-output-translations inherit :collect collect)) - ((:ignore-inherited-configuration) + ((:ignore-inherited-configuration nil) nil)) (let ((src (first directive)) (dst (second directive))) @@ -2869,7 +2967,7 @@ (process-output-translations (pathname dst) :inherit nil :collect collect)) (when src (let ((trusrc (or (eql src t) - (let ((loc (resolve-location src t))) + (let ((loc (resolve-location src :directory t :wilden t))) (if (absolute-pathname-p loc) (truenamize loc) loc))))) (cond ((location-function-p dst) @@ -2882,14 +2980,14 @@ (funcall collect (list trusrc t))) (t (let* ((trudst (make-pathname - :defaults (if dst (resolve-location dst t) trusrc))) + :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc))) (wilddst (make-pathname :name :wild :type :wild :version :wild :defaults trudst))) (funcall collect (list wilddst t)) (funcall collect (list trusrc trudst))))))))))) -(defun compute-output-translations (&optional parameter) +(defun* compute-output-translations (&optional parameter) "read the configuration, return it" (remove-duplicates (while-collecting (c) @@ -2897,12 +2995,12 @@ `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c)) :test 'equal :from-end t)) -(defun initialize-output-translations (&optional parameter) +(defun* initialize-output-translations (&optional parameter) "read the configuration, initialize the internal configuration variable, return the configuration" (setf (output-translations) (compute-output-translations parameter))) -(defun disable-output-translations () +(defun* disable-output-translations () "Initialize output translations in a way that maps every file to itself, effectively disabling the output translation facility." (initialize-output-translations @@ -2912,12 +3010,28 @@ ;; 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). -(defun ensure-output-translations () +(defun* ensure-output-translations () (if (output-translations-initialized-p) (output-translations) (initialize-output-translations))) -(defun apply-output-translations (path) +(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) (etypecase path (logical-pathname path) @@ -2934,20 +3048,7 @@ (root (merge-pathnames* source root)) (t source)) :when (or (eq source t) (pathname-match-p p absolute-source)) - :return - (cond - ((functionp destination) - (funcall destination p absolute-source)) - ((eq destination t) - p) - ((not (pathnamep destination)) - (error "invalid destination")) - ((not (absolute-pathname-p destination)) - (translate-pathname p absolute-source (merge-pathnames* destination root))) - (root - (translate-pathname (directorize-pathname-host-device p) absolute-source destination)) - (t - (translate-pathname p absolute-source destination))) + :return (translate-pathname* p absolute-source destination root source) :finally (return p))))) (defmethod output-files :around (operation component) @@ -2960,24 +3061,24 @@ (mapcar #'apply-output-translations files))) t)) -(defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) +(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) (or output-file (apply-output-translations (apply 'compile-file-pathname (truenamize (lispize-pathname input-file)) keys)))) -(defun tmpize-pathname (x) +(defun* tmpize-pathname (x) (make-pathname :name (format nil "ASDF-TMP-~A" (pathname-name x)) :defaults x)) -(defun delete-file-if-exists (x) +(defun* delete-file-if-exists (x) (when (and x (probe-file x)) (delete-file x))) -(defun compile-file* (input-file &rest keys &key &allow-other-keys) - (let* ((output-file (apply 'compile-file-pathname* input-file keys)) +(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys) + (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys))) (tmp-file (tmpize-pathname output-file)) (status :error)) (multiple-value-bind (output-truename warnings-p failure-p) @@ -3001,7 +3102,7 @@ (values output-truename warnings-p failure-p)))) #+abcl -(defun translate-jar-pathname (source wildcard) +(defun* translate-jar-pathname (source wildcard) (declare (ignore wildcard)) (let* ((p (pathname (first (pathname-device source)))) (root (format nil "/___jar___file___root___/~@[~A/~]" @@ -3017,7 +3118,7 @@ ;;;; ----------------------------------------------------------------- ;;;; Compatibility mode for ASDF-Binary-Locations -(defun enable-asdf-binary-locations-compatibility +(defun* enable-asdf-binary-locations-compatibility (&key (centralize-lisp-binaries nil) (default-toplevel-directory @@ -3025,8 +3126,11 @@ (merge-pathnames* (make-pathname :directory '(:relative ".fasls")) (user-homedir))) (include-per-user-information nil) - (map-all-source-files nil) + (map-all-source-files (or #+(or ecl clisp) t nil)) (source-to-target-mappings nil)) + #+(or ecl clisp) + (when (null map-all-source-files) + (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP")) (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp"))) (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors))) (mapped-files (make-pathname @@ -3053,21 +3157,23 @@ ;;;; Jesse Hager: The Windows Shortcut File Format. ;;;; http://www.wotsit.org/list.asp?fc=13 +#+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp)) +(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) +(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)) +(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) +(defun* parse-file-location-info (s) (let ((start (file-position s)) (total-length (read-little-endian s)) (end-of-header (read-little-endian s)) @@ -3091,7 +3197,7 @@ (file-position s (+ start remaining-offset)) (read-null-terminated-string s)))))) -(defun parse-windows-shortcut (pathname) +(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*) @@ -3119,7 +3225,7 @@ (read-sequence buffer s) (map 'string #'code-char buffer))))))) (end-of-file () - nil)))) + nil))))) ;;;; ----------------------------------------------------------------- ;;;; Source Registry Configuration, by Francois-Rene Rideau @@ -3127,9 +3233,11 @@ ;; Using ack 1.2 exclusions (defvar *default-source-registry-exclusions* - '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst" + '(".bzr" ".cdv" + ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" - "_sgbak" "autom4te.cache" "cover_db" "_build")) + "_sgbak" "autom4te.cache" "cover_db" "_build" + "debian")) ;; debian often build stuff under the debian directory... BAD. (defvar *source-registry-exclusions* *default-source-registry-exclusions*) @@ -3137,50 +3245,105 @@ "Either NIL (for uninitialized), or a list of one element, said element itself being a list of directory pathnames where to look for .asd files") -(defun source-registry () +(defun* source-registry () (car *source-registry*)) -(defun (setf source-registry) (new-value) +(defun* (setf source-registry) (new-value) (setf *source-registry* (list new-value)) new-value) -(defun source-registry-initialized-p () +(defun* source-registry-initialized-p () (and *source-registry* t)) -(defun clear-source-registry () +(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." (setf *source-registry* '()) (values)) -(defun validate-source-registry-directive (directive) +(defparameter *wild-asd* + (make-pathname :directory nil :name :wild :type "asd" :version :newest)) + +(defun directory-has-asd-files-p (directory) + (and (ignore-errors + (directory (merge-pathnames* *wild-asd* directory) + #+sbcl #+sbcl :resolve-symlinks nil + #+ccl #+ccl :follow-links nil + #+clisp #+clisp :circle t)) + t)) + +(defun subdirectories (directory) + (let* ((directory (ensure-directory-pathname directory)) + #-cormanlisp + (wild (merge-pathnames* + #-(or abcl allegro lispworks scl) + (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil) + #+(or abcl allegro lispworks scl) "*.*" + directory)) + (dirs + #-cormanlisp + (ignore-errors + (directory wild . + #.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) + #+ccl '(:follow-links nil :directories t :files nil) + #+clisp '(:circle t :if-does-not-exist :ignore) + #+(or cmu scl) '(:follow-links nil :truenamep nil) + #+digitool '(:directories t) + #+sbcl '(:resolve-symlinks nil)))) + #+cormanlisp (cl::directory-subdirs directory)) + #+(or abcl allegro lispworks scl) + (dirs (remove-if-not #+abcl #'extensions:probe-directory + #+allegro #'excl:probe-directory + #+lispworks #'lw:file-directory-p + #-(or abcl allegro lispworks) #'directory-pathname-p + dirs))) + dirs)) + +(defun collect-sub*directories (directory collectp recursep collector) + (when (funcall collectp directory) + (funcall collector directory)) + (dolist (subdir (subdirectories directory)) + (when (funcall recursep subdir) + (collect-sub*directories subdir collectp recursep collector)))) + +(defun collect-sub*directories-with-asd + (directory &key + (exclude *default-source-registry-exclusions*) + collect) + (collect-sub*directories + directory + #'directory-has-asd-files-p + #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal))) + collect)) + +(defun* validate-source-registry-directive (directive) (unless (or (member directive '(:default-registry (:default-registry)) :test 'equal) (destructuring-bind (kw &rest rest) directive (case kw ((:include :directory :tree) (and (length=n-p rest 1) - (typep (car rest) '(or pathname string null)))) + (location-designator-p (first rest)))) ((:exclude :also-exclude) (every #'stringp rest)) (null rest)))) (error "Invalid directive ~S~%" directive)) directive) -(defun validate-source-registry-form (form) +(defun* validate-source-registry-form (form) (validate-configuration-form form :source-registry 'validate-source-registry-directive "a source registry")) -(defun validate-source-registry-file (file) +(defun* validate-source-registry-file (file) (validate-configuration-file file 'validate-source-registry-form "a source registry")) -(defun validate-source-registry-directory (directory) +(defun* validate-source-registry-directory (directory) (validate-configuration-directory directory :source-registry 'validate-source-registry-directive)) -(defun parse-source-registry-string (string) +(defun* parse-source-registry-string (string) (cond ((or (null string) (equal string "")) '(:source-registry :inherit-configuration)) @@ -3214,25 +3377,11 @@ (push '(:ignore-inherited-configuration) directives)) (return `(:source-registry ,@(nreverse directives)))))))))) -(defun register-asd-directory (directory &key recurse exclude collect) +(defun* register-asd-directory (directory &key recurse exclude collect) (if (not recurse) (funcall collect directory) - (let* ((files - (handler-case - (directory (merge-pathnames* *wild-asd* directory) - #+sbcl #+sbcl :resolve-symlinks nil - #+clisp #+clisp :circle t) - (error (c) - (warn "Error while scanning system definitions under directory ~S:~%~A" - directory c) - nil))) - (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files) - :test #'equal :from-end t))) - (loop - :for dir :in dirs - :unless (loop :for x :in exclude - :thereis (find x (pathname-directory dir) :test #'equal)) - :do (funcall collect dir))))) + (collect-sub*directories-with-asd + directory :exclude exclude :collect collect))) (defparameter *default-source-registries* '(environment-source-registry @@ -3245,12 +3394,12 @@ (defparameter *source-registry-file* #p"source-registry.conf") (defparameter *source-registry-directory* #p"source-registry.conf.d/") -(defun wrapping-source-registry () +(defun* wrapping-source-registry () `(:source-registry #+sbcl (:tree ,(getenv "SBCL_HOME")) :inherit-configuration #+cmu (:tree #p"modules:"))) -(defun default-source-registry () +(defun* default-source-registry () (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) `(:source-registry #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir))) @@ -3276,18 +3425,18 @@ :collect `(:directory ,(try dir "common-lisp/systems/")) :collect `(:tree ,(try dir "common-lisp/source/")))) :inherit-configuration))) -(defun user-source-registry () +(defun* user-source-registry () (in-user-configuration-directory *source-registry-file*)) -(defun system-source-registry () +(defun* system-source-registry () (in-system-configuration-directory *source-registry-file*)) -(defun user-source-registry-directory () +(defun* user-source-registry-directory () (in-user-configuration-directory *source-registry-directory*)) -(defun system-source-registry-directory () +(defun* system-source-registry-directory () (in-system-configuration-directory *source-registry-directory*)) -(defun environment-source-registry () +(defun* environment-source-registry () (getenv "CL_SOURCE_REGISTRY")) -(defgeneric process-source-registry (spec &key inherit register)) +(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) @@ -3316,24 +3465,25 @@ (dolist (directive (cdr (validate-source-registry-form form))) (process-source-registry-directive directive :inherit inherit :register register)))) -(defun inherit-source-registry (inherit &key 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) +(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 (pathname pathname) :inherit nil :register register))) + (process-source-registry (resolve-location pathname) :inherit nil :register register))) ((:directory) (destructuring-bind (pathname) rest (when pathname - (funcall register (ensure-directory-pathname pathname))))) + (funcall register (resolve-location pathname :directory t))))) ((:tree) (destructuring-bind (pathname) rest (when pathname - (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*)))) + (funcall register (resolve-location pathname :directory t) + :recurse t :exclude *source-registry-exclusions*)))) ((:exclude) (setf *source-registry-exclusions* rest)) ((:also-exclude) @@ -3346,7 +3496,7 @@ nil))) nil) -(defun flatten-source-registry (&optional parameter) +(defun* flatten-source-registry (&optional parameter) (remove-duplicates (while-collecting (collect) (inherit-source-registry @@ -3359,7 +3509,7 @@ ;; Will read the configuration and initialize all internal variables, ;; and return the new configuration. -(defun compute-source-registry (&optional parameter) +(defun* compute-source-registry (&optional parameter) (while-collecting (collect) (dolist (entry (flatten-source-registry parameter)) (destructuring-bind (directory &key recurse exclude) entry @@ -3367,7 +3517,7 @@ directory :recurse recurse :exclude exclude :collect #'collect))))) -(defun initialize-source-registry (&optional parameter) +(defun* initialize-source-registry (&optional parameter) (setf (source-registry) (compute-source-registry parameter))) ;; Checks an initial variable to see whether the state is initialized @@ -3378,41 +3528,49 @@ ;; 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) +(defun* ensure-source-registry (&optional parameter) (if (source-registry-initialized-p) (source-registry) (initialize-source-registry parameter))) -(defun sysdef-source-registry-search (system) +(defun* sysdef-source-registry-search (system) (ensure-source-registry) (loop :with name = (coerce-name system) :for defaults :in (source-registry) :for file = (probe-asd name defaults) :when file :return file)) +(defun* clear-configuration () + (clear-source-registry) + (clear-output-translations)) + ;;;; ----------------------------------------------------------------- ;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL ;;;; -#+(or abcl clozure cmu ecl sbcl) -(progn - (defun module-provide-asdf (name) - (handler-bind - ((style-warning #'muffle-warning) - (missing-component (constantly nil)) - (error (lambda (e) - (format *error-output* "ASDF could not load ~(~A~) because ~A.~%" - name e)))) - (let* ((*verbose-out* (make-broadcast-stream)) - (system (find-system (string-downcase name) nil))) - (when system - (load-system system) - t)))) - (pushnew 'module-provide-asdf - #+abcl sys::*module-provider-functions* - #+clozure ccl:*module-provider-functions* - #+cmu ext:*module-provider-functions* - #+ecl si:*module-provider-functions* - #+sbcl sb-ext:*module-provider-functions*)) +(defun* module-provide-asdf (name) + (handler-bind + ((style-warning #'muffle-warning) + (missing-component (constantly nil)) + (error (lambda (e) + (format *error-output* "ASDF could not load ~(~A~) because ~A.~%" + name e)))) + (let* ((*verbose-out* (make-broadcast-stream)) + (system (find-system (string-downcase name) nil))) + (when system + (load-system system) + t)))) + +#+(or abcl clisp clozure cmu ecl sbcl) +(let ((x (and #+clisp (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" :custom)))) + (when x + (eval `(pushnew 'module-provide-asdf + #+abcl sys::*module-provider-functions* + #+clisp ,x + #+clozure ccl:*module-provider-functions* + #+cmu ext:*module-provider-functions* + #+ecl si:*module-provider-functions* + #+sbcl sb-ext:*module-provider-functions*)))) + ;;;; ------------------------------------------------------------------------- ;;;; Cleanups after hot-upgrade. From mevenson at common-lisp.net Sun Oct 31 08:48:47 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 31 Oct 2010 04:48:47 -0400 Subject: [armedbear-cvs] r12987 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun Oct 31 04:48:46 2010 New Revision: 12987 Log: Use a lexical variable rather than SETQ for backtrace This definitely corrects bad style, and PRINT-FRAME should not be modifying its arguments. Modified: trunk/abcl/src/org/armedbear/lisp/top-level.lisp Modified: trunk/abcl/src/org/armedbear/lisp/top-level.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/top-level.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/top-level.lisp Sun Oct 31 04:48:46 2010 @@ -108,14 +108,14 @@ (write-string prefix stream)) (etypecase frame (sys::lisp-stack-frame - (pprint-logical-block (stream nil :prefix "(" :suffix ")") - (setq frame (sys:frame-to-list frame)) - (ignore-errors - (prin1 (car frame) stream) - (let ((args (cdr frame))) - (if (listp args) - (format stream "~{ ~_~S~}" args) - (format stream " ~S" args)))))) + (let ((frame (sys:frame-to-list frame))) + (pprint-logical-block (stream nil :prefix "(" :suffix ")") + (ignore-errors + (prin1 (car frame) stream) + (let ((args (cdr frame))) + (if (listp args) + (format stream "~{ ~_~S~}" args) + (format stream " ~S" args))))))) (sys::java-stack-frame (write-string (sys:frame-to-string frame) stream)))) From mevenson at common-lisp.net Sun Oct 31 08:50:03 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 31 Oct 2010 04:50:03 -0400 Subject: [armedbear-cvs] r12988 - trunk/abcl Message-ID: Author: mevenson Date: Sun Oct 31 04:50:02 2010 New Revision: 12988 Log: Include example 'abcl.properties.in' in source release Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Sun Oct 31 04:50:02 2010 @@ -477,7 +477,7 @@ - + From vvoutilainen at common-lisp.net Sun Oct 31 18:04:03 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 31 Oct 2010 14:04:03 -0400 Subject: [armedbear-cvs] r12989 - trunk/abcl Message-ID: Author: vvoutilainen Date: Sun Oct 31 14:04:00 2010 New Revision: 12989 Log: Add changelog entry for wild-inferiors support for DIRECTORY. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Sun Oct 31 14:04:00 2010 @@ -28,6 +28,7 @@ * [ticket #107] Incorrect compilation of (SETF STRUCTURE-REF) expansion +* [ticket #105] DIRECTORY ignores :WILD-INFERIORS Other ----- From vvoutilainen at common-lisp.net Sun Oct 31 18:08:40 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 31 Oct 2010 14:08:40 -0400 Subject: [armedbear-cvs] r12990 - trunk/abcl Message-ID: Author: vvoutilainen Date: Sun Oct 31 14:08:40 2010 New Revision: 12990 Log: Mention the current asdf version in changelog. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Sun Oct 31 14:08:40 2010 @@ -3,6 +3,11 @@ svn://common-lisp.net/project/armedbear/svn/tags/0.23.0/abcl (????, 2010) +Features +-------- + +* [svn r12986] Update to ASDF 2.010.1 + Fixes ----- From vvoutilainen at common-lisp.net Sun Oct 31 18:13:34 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 31 Oct 2010 14:13:34 -0400 Subject: [armedbear-cvs] r12991 - trunk/abcl Message-ID: Author: vvoutilainen Date: Sun Oct 31 14:13:33 2010 New Revision: 12991 Log: Mention the CLOS thread-safety fix in changelog. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Sun Oct 31 14:13:33 2010 @@ -11,6 +11,8 @@ Fixes ----- +* [svn r12946] Fix CLOS thread-safety + * [svn r12930] Fix non-constantness of constant symbols when using SET * [svn r12929] Don't throw conditions on floating point underflow From mevenson at common-lisp.net Sun Oct 31 19:08:18 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 31 Oct 2010 15:08:18 -0400 Subject: [armedbear-cvs] r12992 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun Oct 31 15:08:17 2010 New Revision: 12992 Log: Remove deleted functions in THREADS from autoloads Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Sun Oct 31 15:08:17 2010 @@ -327,7 +327,7 @@ mailbox-read mailbox-peek ;; Lock - make-thread-lock thread-lock thread-unlock + make-thread-lock ;; Mutex make-mutex get-mutex release-mutex)