From ehuelsmann at common-lisp.net Mon Feb 1 22:14:11 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 01 Feb 2010 17:14:11 -0500 Subject: [armedbear-cvs] r12412 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Feb 1 17:14:07 2010 New Revision: 12412 Log: Make format.lisp a lot more memory-efficient by replacing an array of size CHAR-CODE-LIMIT with a hash table. Modified: trunk/abcl/src/org/armedbear/lisp/format.lisp Modified: trunk/abcl/src/org/armedbear/lisp/format.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/format.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/format.lisp Mon Feb 1 17:14:07 2010 @@ -297,9 +297,9 @@ #\tab)) (defvar *format-directive-expanders* - (make-array char-code-limit :initial-element nil)) + (make-hash-table :test #'eq)) (defvar *format-directive-interpreters* - (make-array char-code-limit :initial-element nil)) + (make-hash-table :test #'eq)) (defvar *default-format-error-control-string* nil) (defvar *default-format-error-offset* nil) @@ -594,8 +594,8 @@ (etypecase directive (format-directive (let ((expander - (aref *format-directive-expanders* - (char-code (format-directive-character directive)))) + (gethash (format-directive-character directive) + *format-directive-expanders*)) (*default-format-error-offset* (1- (format-directive-end directive)))) (declare (type (or null function) expander)) @@ -711,13 +711,11 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defun %set-format-directive-expander (char fn) - (setf (aref *format-directive-expanders* (char-code (char-upcase char))) fn) + (setf (gethash (char-upcase char) *format-directive-expanders*) fn) char) (defun %set-format-directive-interpreter (char fn) - (setf (aref *format-directive-interpreters* - (char-code (char-upcase char))) - fn) + (setf (gethash (char-upcase char) *format-directive-interpreters*) fn) char) (defun find-directive (directives kind stop-at-semi) @@ -1763,8 +1761,7 @@ (multiple-value-bind (new-directives new-args) (let* ((character (format-directive-character directive)) (function - (svref *format-directive-interpreters* - (char-code character))) + (gethash character *format-directive-interpreters*)) (*default-format-error-offset* (1- (format-directive-end directive)))) (unless function From ehuelsmann at common-lisp.net Mon Feb 1 22:16:12 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 01 Feb 2010 17:16:12 -0500 Subject: [armedbear-cvs] r12413 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Feb 1 17:16:11 2010 New Revision: 12413 Log: Use MACROLET to prevent code repetition. 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 Mon Feb 1 17:16:11 2010 @@ -340,6 +340,11 @@ (defun emit-push-nil () (emit 'getstatic +lisp-class+ "NIL" +lisp-object+)) +(defknown emit-push-nil-symbol () t) +(declaim (inline emit-push-nil-symbol)) +(defun emit-push-nil-symbol () + (emit 'getstatic +lisp-nil-class+ "NIL" +lisp-symbol+)) + (defknown emit-push-t () t) (declaim (inline emit-push-t)) (defun emit-push-t () @@ -1844,112 +1849,83 @@ (setf rest-p rest more-keys-p allow-other-keys-p keys-p key-p) - ;; process required args - (emit-push-constant-int (length req)) - (emit 'anewarray +lisp-closure-parameter-class+) - (astore (setf req-params-register (method-max-locals constructor))) - (incf (method-max-locals constructor)) - (do ((i 0 (1+ i)) - (req req (cdr req))) - ((endp req)) - (aload req-params-register) - (emit-push-constant-int i) - (emit 'new +lisp-closure-parameter-class+) - (emit 'dup) - (emit-push-t) ;; we don't need the actual symbol - (emit-invokespecial-init +lisp-closure-parameter-class+ - (list +lisp-symbol+)) - (emit 'aastore)) - - ;; process optional args - (emit-push-constant-int (length opt)) - (emit 'anewarray +lisp-closure-parameter-class+) - (astore (setf opt-params-register (method-max-locals constructor))) - (incf (method-max-locals constructor)) - (do ((i 0 (1+ i)) - (opt opt (cdr opt))) - ((endp opt)) - (aload opt-params-register) - (emit-push-constant-int i) - (emit 'new +lisp-closure-parameter-class+) - (emit 'dup) - (emit-push-t) ;; we don't need the actual variable-symbol - (emit-read-from-string (second (car opt))) ;; initform - (if (null (third (car opt))) ;; - (emit-push-nil) - (emit-push-t)) ;; we don't need the actual supplied-p symbol - (emit 'getstatic +lisp-closure-class+ "OPTIONAL" "I") - (emit-invokespecial-init +lisp-closure-parameter-class+ - (list +lisp-symbol+ +lisp-object+ - +lisp-object+ "I")) - (emit 'aastore)) - - ;; process key args - (emit-push-constant-int (length key)) - (emit 'anewarray +lisp-closure-parameter-class+) - (astore (setf key-params-register (method-max-locals constructor))) - (incf (method-max-locals constructor)) - (do ((i 0 (1+ i)) - (key key (cdr key))) - ((endp key)) - (aload key-params-register) - (emit-push-constant-int i) - (emit 'new +lisp-closure-parameter-class+) - (emit 'dup) - (let ((keyword (fourth (car key)))) - (if (keywordp keyword) - (progn - (emit 'ldc (pool-string (symbol-name keyword))) - (emit-invokestatic +lisp-class+ "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-class+ "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 (car key))) - (emit-push-nil) - (emit-push-t)) ;; we don't need the actual supplied-p symbol - (emit-invokespecial-init +lisp-closure-parameter-class+ - (list +lisp-symbol+ +lisp-symbol+ - +lisp-object+ +lisp-object+)) - (emit 'aastore)) - - )) + (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-class+) + (astore (setf ,register (method-max-locals constructor))) + (incf (method-max-locals constructor)) + (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-class+) + (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-class+ + (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-class+ "OPTIONAL" "I") + (emit-invokespecial-init +lisp-closure-parameter-class+ + (list +lisp-symbol+ +lisp-object+ + +lisp-object+ "I"))) + + (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-class+ "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-class+ "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-class+ + (list +lisp-symbol+ +lisp-symbol+ + +lisp-object+ +lisp-object+)))))) (aload 0) ;; this (cond ((equal super +lisp-primitive-class+) (emit-constructor-lambda-name lambda-name) (emit-constructor-lambda-list args) (emit-invokespecial-init super (lisp-object-arg-types 2))) - ((and (null req-params-register) - (equal super +lisp-compiled-closure-class+)) - (emit-constructor-lambda-list args) - (emit-invokespecial-init super (lisp-object-arg-types 1))) - ((and - (equal super +lisp-compiled-closure-class+)) + ((equal super +lisp-compiled-closure-class+) (aload req-params-register) (aload opt-params-register) (aload key-params-register) (if keys-p (emit-push-t) - (progn - (emit-push-nil) - (emit 'checkcast +lisp-symbol-class+))) + (emit-push-nil-symbol)) (if rest-p (emit-push-t) - (progn - (emit-push-nil) - (emit 'checkcast +lisp-symbol-class+))) + (emit-push-nil-symbol)) (if more-keys-p (emit-push-t) - (progn - (emit-push-nil) - (emit 'checkcast +lisp-symbol-class+))) + (emit-push-nil-symbol)) (emit-invokespecial-init super (list +lisp-closure-parameter-array+ +lisp-closure-parameter-array+ From ehuelsmann at common-lisp.net Tue Feb 2 19:54:40 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 02 Feb 2010 14:54:40 -0500 Subject: [armedbear-cvs] r12414 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Feb 2 14:54:37 2010 New Revision: 12414 Log: Add function to retrieve a lisp byte array from a byte array output stream. Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java trunk/abcl/src/org/armedbear/lisp/ByteArrayOutputStream.java (contents, props changed) Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Tue Feb 2 14:54:37 2010 @@ -526,6 +526,7 @@ autoload(PACKAGE_SYS, "%generic-function-lambda-list", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "%generic-function-name", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "%get-output-stream-bytes", "ByteArrayOutputStream"); //AS 20090325 + autoload(PACKAGE_SYS, "%get-output-stream-array", "ByteArrayOutputStream"); autoload(PACKAGE_SYS, "%make-array", "make_array"); autoload(PACKAGE_SYS, "%make-byte-array-output-stream", "ByteArrayOutputStream"); //AS 20090325 autoload(PACKAGE_SYS, "%make-condition", "make_condition", true); Modified: trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java (original) +++ trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java Tue Feb 2 14:54:37 2010 @@ -48,8 +48,15 @@ this.capacity = capacity; } - public BasicVector_UnsignedByte8(LispObject[] array) + public BasicVector_UnsignedByte8(byte[] array) + { + capacity = array.length; + elements = new byte[capacity]; + System.arraycopy(array, 0, elements, 0, capacity); + } + + public BasicVector_UnsignedByte8(LispObject[] array) { capacity = array.length; elements = new byte[capacity]; Modified: trunk/abcl/src/org/armedbear/lisp/ByteArrayOutputStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ByteArrayOutputStream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ByteArrayOutputStream.java Tue Feb 2 14:54:37 2010 @@ -2,7 +2,7 @@ * ByteArrayOutputStream.java * * Copyright (C) 2009 Alessio Stalla - * $Id: StringOutputStream.java 11434 2008-12-07 23:24:31Z ehuelsmann $ + * $Id$ * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License @@ -132,4 +132,19 @@ return error(new TypeError(this, Symbol.STREAM)); //TODO } }; + + private static final Primitive GET_OUTPUT_STREAM_ARRAY = + new Primitive("%get-output-stream-array", PACKAGE_SYS, false, + "byte-array-output-stream") + { + @Override + public LispObject execute(LispObject arg) + { + if (arg instanceof ByteArrayOutputStream) + return new BasicVector_UnsignedByte8(((ByteArrayOutputStream)arg).getByteArray()); + + return error(new TypeError(this, Symbol.STREAM)); // TODO + } + }; + } From ehuelsmann at common-lisp.net Tue Feb 2 21:01:45 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 02 Feb 2010 16:01:45 -0500 Subject: [armedbear-cvs] r12415 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Feb 2 16:01:41 2010 New Revision: 12415 Log: Rename class-file to abcl-class-file in anticipation of a more generic class file representation to come. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.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 Tue Feb 2 16:01:41 2010 @@ -2171,7 +2171,7 @@ (declare-with-hashtable local-function *declared-functions* ht g (setf g (symbol-name (gensym "LFUN"))) - (let* ((pathname (class-file-pathname (local-function-class-file local-function))) + (let* ((pathname (abcl-class-file-pathname (local-function-class-file local-function))) (*code* *static-code*)) ;; fixme *declare-inline* (declare-field g +lisp-object+ +field-access-default+) @@ -8245,19 +8245,19 @@ (get-descriptor (list +lisp-object-array+) +lisp-object+))))) (defmacro with-open-class-file ((var class-file) &body body) - `(with-open-file (,var (class-file-pathname ,class-file) + `(with-open-file (,var (abcl-class-file-pathname ,class-file) :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede) , at body)) (defun write-class-file (class-file stream) - (let* ((super (class-file-superclass class-file)) - (this-index (pool-class (class-file-class class-file))) + (let* ((super (abcl-class-file-superclass class-file)) + (this-index (pool-class (abcl-class-file-class class-file))) (super-index (pool-class super)) (constructor (make-constructor super - (class-file-lambda-name class-file) - (class-file-lambda-list class-file)))) + (abcl-class-file-lambda-name class-file) + (abcl-class-file-lambda-list class-file)))) (pool-name "Code") ; Must be in pool! (when *file-compilation* @@ -8283,9 +8283,9 @@ (dolist (field *fields*) (write-field field stream)) ;; methods count - (write-u2 (1+ (length (class-file-methods class-file))) stream) + (write-u2 (1+ (length (abcl-class-file-methods class-file))) stream) ;; methods - (dolist (method (class-file-methods class-file)) + (dolist (method (abcl-class-file-methods class-file)) (write-method method stream)) (write-method constructor stream) ;; attributes count @@ -8351,7 +8351,7 @@ ;; (format t "p2-compiland name = ~S~%" (compiland-name compiland)) (let* ((p1-result (compiland-p1-result compiland)) (class-file (compiland-class-file compiland)) - (*this-class* (class-file-class class-file)) + (*this-class* (abcl-class-file-class class-file)) (args (cadr p1-result)) (closure-args (intersection *closure-variables* (compiland-arg-vars compiland))) @@ -8568,15 +8568,15 @@ (setf (method-max-locals execute-method) *registers-allocated*) (setf (method-handlers execute-method) (nreverse *handlers*)) - (setf (class-file-superclass class-file) + (setf (abcl-class-file-superclass class-file) (if (or *hairy-arglist-p* (and *child-p* *closure-variables*)) +lisp-compiled-closure-class+ +lisp-primitive-class+)) - (setf (class-file-lambda-list class-file) args) + (setf (abcl-class-file-lambda-list class-file) args) - (push execute-method (class-file-methods class-file))) + (push execute-method (abcl-class-file-methods class-file))) t) (defun compile-1 (compiland stream) Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Tue Feb 2 16:01:41 2010 @@ -89,7 +89,7 @@ (defvar *declared-floats* nil) (defvar *declared-doubles* nil) -(defstruct (class-file (:constructor %make-class-file)) +(defstruct (abcl-class-file (:constructor %make-abcl-class-file)) pathname ; pathname of output file lambda-name class @@ -134,38 +134,38 @@ (let* ((class-name (if pathname (class-name-from-filespec pathname) (make-unique-class-name))) - (class-file (%make-class-file :pathname pathname - :class class-name - :lambda-name lambda-name - :lambda-list lambda-list))) + (class-file (%make-abcl-class-file :pathname pathname + :class class-name + :lambda-name lambda-name + :lambda-list lambda-list))) class-file)) (defmacro with-class-file (class-file &body body) (let ((var (gensym))) `(let* ((,var ,class-file) - (*pool* (class-file-pool ,var)) - (*pool-count* (class-file-pool-count ,var)) - (*pool-entries* (class-file-pool-entries ,var)) - (*fields* (class-file-fields ,var)) - (*static-code* (class-file-static-code ,var)) - (*declared-symbols* (class-file-symbols ,var)) - (*declared-functions* (class-file-functions ,var)) - (*declared-strings* (class-file-strings ,var)) - (*declared-integers* (class-file-integers ,var)) - (*declared-floats* (class-file-floats ,var)) - (*declared-doubles* (class-file-doubles ,var))) + (*pool* (abcl-class-file-pool ,var)) + (*pool-count* (abcl-class-file-pool-count ,var)) + (*pool-entries* (abcl-class-file-pool-entries ,var)) + (*fields* (abcl-class-file-fields ,var)) + (*static-code* (abcl-class-file-static-code ,var)) + (*declared-symbols* (abcl-class-file-symbols ,var)) + (*declared-functions* (abcl-class-file-functions ,var)) + (*declared-strings* (abcl-class-file-strings ,var)) + (*declared-integers* (abcl-class-file-integers ,var)) + (*declared-floats* (abcl-class-file-floats ,var)) + (*declared-doubles* (abcl-class-file-doubles ,var))) (progn , at body) - (setf (class-file-pool ,var) *pool* - (class-file-pool-count ,var) *pool-count* - (class-file-pool-entries ,var) *pool-entries* - (class-file-fields ,var) *fields* - (class-file-static-code ,var) *static-code* - (class-file-symbols ,var) *declared-symbols* - (class-file-functions ,var) *declared-functions* - (class-file-strings ,var) *declared-strings* - (class-file-integers ,var) *declared-integers* - (class-file-floats ,var) *declared-floats* - (class-file-doubles ,var) *declared-doubles*)))) + (setf (abcl-class-file-pool ,var) *pool* + (abcl-class-file-pool-count ,var) *pool-count* + (abcl-class-file-pool-entries ,var) *pool-entries* + (abcl-class-file-fields ,var) *fields* + (abcl-class-file-static-code ,var) *static-code* + (abcl-class-file-symbols ,var) *declared-symbols* + (abcl-class-file-functions ,var) *declared-functions* + (abcl-class-file-strings ,var) *declared-strings* + (abcl-class-file-integers ,var) *declared-integers* + (abcl-class-file-floats ,var) *declared-floats* + (abcl-class-file-doubles ,var) *declared-doubles*)))) (defstruct compiland name From astalla at common-lisp.net Wed Feb 3 23:55:28 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Wed, 03 Feb 2010 18:55:28 -0500 Subject: [armedbear-cvs] r12416 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Wed Feb 3 18:55:25 2010 New Revision: 12416 Log: Fixed lambda.nn test failures caused by errors in lambda inlining. 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 Wed Feb 3 18:55:25 2010 @@ -205,9 +205,8 @@ :for var-info :in aux :collect `(,(var var-info) ,(initform var-info)))))) - (values - (append req-bindings temp-bindings bindings) - ignorables))))) + (values (append req-bindings temp-bindings bindings) + ignorables))))) (defun match-keyword-and-rest-args (key allow-others-p rest arguments) (flet ((var (var-info) (car var-info)) @@ -218,7 +217,8 @@ (error 'lambda-list-mismatch :mismatch-type :odd-number-of-keyword-arguments)) - (let (temp-bindings bindings other-keys-found-p ignorables) + (let (temp-bindings bindings other-keys-found-p ignorables already-seen + args) ;;If necessary, make up a fake argument to hold :allow-other-keys, ;;needed later. This also handles nicely: ;; 3.4.1.4.1 Suppressing Keyword Argument Checking @@ -236,24 +236,34 @@ :for var :in arguments :by #'cddr :for value :in (cdr arguments) by #'cddr :do (let ((var-info (find var key :key #'keyword))) - (if var-info + (if (and var-info (not (member var already-seen))) ;;var is one of the declared keyword arguments (progn (push-argument-binding (var var-info) value temp-bindings bindings) - ;(push `(,(var var-info) ,value) bindings) (when (p-var var-info) - (push `(,(p-var var-info) t) bindings))) - (setf other-keys-found-p t)))) + (push `(,(p-var var-info) t) bindings)) + (push var args) + (push (var var-info) args) + (push var already-seen)) + (let ((g (gensym))) + (push `(,g ,value) temp-bindings) + (push var args) + (push g args) + (push g ignorables) + (unless var-info + (setf other-keys-found-p t)))))) ;;Then, let's bind those arguments that haven't been passed in ;;to their default value, in declaration order. - (loop - :for var-info :in key - :do (unless (find (var var-info) bindings :key #'car) - (push `(,(var var-info) ,(initform var-info)) bindings) - (when (p-var var-info) - (push `(,(p-var var-info) nil) bindings)))) + (let (defaults) + (loop + :for var-info :in key + :do (unless (find (var var-info) bindings :key #'car) + (push `(,(var var-info) ,(initform var-info)) defaults) + (when (p-var var-info) + (push `(,(p-var var-info) nil) defaults)))) + (setf bindings (append (nreverse defaults) bindings))) ;;If necessary, check for unrecognized keyword arguments. (when (and other-keys-found-p (not allow-others-p)) @@ -279,23 +289,9 @@ ;;is unknown (error 'lambda-list-mismatch :mismatch-type :unknown-keyword))) (when rest - (push `(,(var rest) - (list ,@(let (list) - (loop - :for var :in arguments :by #'cddr - :for val :in (cdr arguments) :by #'cddr - :do (let ((bound-var - (var (find var key :key #'keyword)))) - (push var list) - (if bound-var - (push bound-var list) - (push val list)))) - (nreverse list)))) - bindings)) - (values - (nreverse bindings) - temp-bindings - ignorables)))) + (setf bindings (append bindings `((,(var rest) (list ,@(nreverse args))))))) + (print bindings) + (values bindings temp-bindings ignorables)))) #||test for the above (handler-case From mevenson at common-lisp.net Thu Feb 4 09:42:19 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Thu, 04 Feb 2010 04:42:19 -0500 Subject: [armedbear-cvs] r12417 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: mevenson Date: Thu Feb 4 04:42:16 2010 New Revision: 12417 Log: Fix TRANSLATE-LOGICAL-PATHNAME regression. Problem and solution found by Alan Ruttenburg. Closes ticket:83. Modified: trunk/abcl/src/org/armedbear/lisp/pathnames.lisp trunk/abcl/test/lisp/abcl/bugs.lisp Modified: trunk/abcl/src/org/armedbear/lisp/pathnames.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/pathnames.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/pathnames.lisp Thu Feb 4 04:42:16 2010 @@ -203,7 +203,12 @@ ((and to (not (member (car to) '(:wild :wild-inferiors)))) (cons (casify (car to) case) - (translate-directory-components-aux src from (cdr to) case))) + (translate-directory-components-aux + src from (cdr to) case))) + ((and (not src) + (eq (car from) :wild-inferiors) + (eq (car to) :wild-inferiors)) + (translate-directory-components-aux src (cdr from) (cdr to) case)) ((not (and src from)) ;; both are NIL --> TO is a wildcard which can't be matched ;; either is NIL --> SRC can't be fully matched against FROM, vice versa @@ -224,8 +229,9 @@ (NIL) ;; we'll exit the loop in different ways (catch 'failed-match (return-from translate-directory-components-aux - (append (reverse match) (translate-directory-components-aux - src (cdr from) (cdr to) case)))) + (append (reverse match) + (translate-directory-components-aux + src (cdr from) (cdr to) case)))) (when (null src) ;; SRC is NIL and we're still here: error exit (throw 'failed-match)))))) Modified: trunk/abcl/test/lisp/abcl/bugs.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/bugs.lisp (original) +++ trunk/abcl/test/lisp/abcl/bugs.lisp Thu Feb 4 04:42:16 2010 @@ -3,24 +3,39 @@ ;;; When these bugs get fixed, they should be moved elsewhere in the ;;; testsuite so they remain fixed. -(deftest bugs.translate-logical-pathname +(deftest bugs.logical-pathname.1 #| - Date: Mon, 18 Jan 2010 10:51:07 -0500 - Message-ID: <29af5e2d1001180751l7cf79a3ay929cef1deb9ed063 at mail.gmail.com> - Subject: Re: [armedbear-devel] translate-logical-pathname and :wild-inferiors - regression - From: Alan Ruttenberg +Date: Mon, 18 Jan 2010 10:51:07 -0500 +Message-ID: <29af5e2d1001180751l7cf79a3ay929cef1deb9ed063 at mail.gmail.com> +Subject: Re: [armedbear-devel] translate-logical-pathname and :wild-inferiors +regression +From: Alan Ruttenberg |# (progn (setf (logical-pathname-translations "ido") - '((#P"IDO:IDO-CORE;**;*.*" - #P"/Users/alanr/repos/infectious-disease-ontology/trunk/src/ontology/ido-core/**/*.*") - (#P"IDO:IMMUNOLOGY;**;*.*" - #P"/Users/alanr/repos/infectious-disease-ontology/trunk/src/ontology/immunology/**/*.*") - (#P"IDO:TOOLS;**;*.*" - #P"/Users/alanr/repos/infectious-disease-ontology/trunk/src/tools/**/*.*") - (#P"IDO:LIB;**;*.*" - #P"/Users/alanr/repos/infectious-disease-ontology/trunk/lib/**/*.*"))) - (translate-pathname #P"IDO:IMMUNOLOGY;" #P"IDO:IMMUNOLOGY;**;*.*" - #P"/Users/alanr/repos/infectious-disease-ontology/trunk/src/ontology/**/*.*")) - #P"/users/alanr/repos/infectious-disease-ontology/trunk/src/ontology/immunology/") \ No newline at end of file + '(("IDO:IDO-CORE;**;*.*" + "/Users/alanr/repos/infectious-disease-ontology/trunk/src/ontology/ido-core/**/*.*") + ("IDO:IMMUNOLOGY;**;*.*" + "/Users/alanr/repos/infectious-disease-ontology/trunk/src/ontology/immunology/**/*.*") + ("IDO:TOOLS;**;*.*" + "/Users/alanr/repos/infectious-disease-ontology/trunk/src/tools/**/*.*") + ("IDO:LIB;**;*.*" + "/Users/alanr/repos/infectious-disease-ontology/trunk/lib/**/*.*"))) + (translate-pathname "IDO:IMMUNOLOGY;" "IDO:IMMUNOLOGY;**;*.*" + "/Users/alanr/repos/infectious-disease-ontology/trunk/src/ontology/**/*.*")) + #P"/users/alanr/repos/infectious-disease-ontology/trunk/src/ontology/") + +(deftest bugs.logical.pathname.2 + #| +Message-Id: +From: Thomas Russ +To: armedbear-devel at common-lisp.net +Subject: [armedbear-devel] Bug in translate-logical-pathname. + |# + (progn + (setf (logical-pathname-translations "L") + '(("L:NATIVE;**;*.*" "/usr/lisp/abcl/native/**/*.*"))) + (translate-logical-pathname "L:NATIVE;TEST;FOO.FASL")) + #p"/usr/lisp/abcl/native/test/foo.fasl") + + From mevenson at common-lisp.net Fri Feb 5 15:41:45 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 05 Feb 2010 10:41:45 -0500 Subject: [armedbear-cvs] r12418 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Feb 5 10:41:42 2010 New Revision: 12418 Log: Fix svn:eol-style. Modified: trunk/abcl/src/org/armedbear/lisp/package.lisp (contents, props changed) Modified: trunk/abcl/src/org/armedbear/lisp/package.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/package.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/package.lisp Fri Feb 5 10:41:42 2010 @@ -1,21 +1,21 @@ -;;; package.lisp -;;; -;;; Copyright (C) 2008 Erik Huelsmann -;;; $Id$ -;;; -;;; This program is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU General Public License -;;; as published by the Free Software Foundation; either version 2 -;;; of the License, or (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; package.lisp +;;; +;;; Copyright (C) 2008 Erik Huelsmann +;;; $Id$ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; As a special exception, the copyright holders of this library give you ;;; permission to link this library with independent modules to produce an @@ -28,67 +28,68 @@ ;;; this exception to your version of the library, but you are not ;;; obligated to do so. If you do not wish to do so, delete this ;;; exception statement from your version. - -(in-package "SYSTEM") - -;; Redefines make-package from boot.lisp - -(defun make-package (name &key nicknames use) - (restart-case - (progn - (when (find-package name) - (error 'simple-error "Package ~A already exists." name)) - (dolist (nick nicknames) - (when (find-package nick) - (error 'package-error :package nick))) - (%make-package name nicknames use)) - (use-existing-package () - :report "Use existing package" - (return-from make-package (find-package name))))) - -;; Redefines function from defpackage.lisp, because there it's lacking restart-case - -(defun ensure-available-symbols (imports) - (remove nil - (mapcar #'(lambda (package-and-symbols) - (let* ((package (find-package (designated-package-name (car package-and-symbols)))) - (new-symbols - (remove nil - (mapcar #'(lambda (sym) - (restart-case - (progn - (unless (find-symbol sym package) - (error 'package-error - "The symbol ~A is not present in package ~A." sym (package-name package))) - sym) - (skip () - :report "Skip this symbol." - nil))) - (cdr package-and-symbols))))) - (when new-symbols - (cons package new-symbols)))) - imports))) - - - - -(defun import (symbols &optional (package *package* package-supplied-p)) - (dolist (symbol (if (listp symbols) symbols (list symbols))) - (let* ((sym-name (string symbol)) - (local-sym (find-symbol sym-name package))) - (restart-case - (progn - (when (and local-sym (not (eql symbol local-sym))) - (error 'package-error - "Different symbol (~A) with the same name already accessible in package ~A." - local-sym (package-name package))) - (if package-supplied-p - (%import (list symbol) package) ;; in order to pass NIL, wrap in a list - (%import (list symbol)))) - (unintern-existing () - :report (lambda (s) (format s "Unintern ~S and continue" local-sym)) - (unintern local-sym) - (%import symbol)) - (skip () - :report "Skip symbol")))) - T) + +(in-package "SYSTEM") + +;; Redefines make-package from boot.lisp + +(defun make-package (name &key nicknames use) + (restart-case + (progn + (when (find-package name) + (error 'simple-error "Package ~A already exists." name)) + (dolist (nick nicknames) + (when (find-package nick) + (error 'package-error :package nick))) + (%make-package name nicknames use)) + (use-existing-package () + :report "Use existing package" + (return-from make-package (find-package name))))) + +;; Redefines function from defpackage.lisp, because there it's lacking restart-case + +(defun ensure-available-symbols (imports) + (remove nil + (mapcar #'(lambda (package-and-symbols) + (let* ((package (find-package (designated-package-name (car package-and-symbols)))) + (new-symbols + (remove nil + (mapcar #'(lambda (sym) + (restart-case + (progn + (unless (find-symbol sym package) + (error 'package-error + "The symbol ~A is not present in package ~A." sym (package-name package))) + sym) + (skip () + :report "Skip this symbol." + nil))) + (cdr package-and-symbols))))) + (when new-symbols + (cons package new-symbols)))) + imports))) + + + + +(defun import (symbols &optional (package *package* package-supplied-p)) + (dolist (symbol (if (listp symbols) symbols (list symbols))) + (let* ((sym-name (string symbol)) + (local-sym (find-symbol sym-name package))) + (restart-case + (progn + (when (and local-sym (not (eql symbol local-sym))) + (error 'package-error + "Different symbol (~A) with the same name already accessible in package ~A." + local-sym (package-name package))) + (if package-supplied-p + (%import (list symbol) package) ;; in order to pass NIL, wrap in a list + (%import (list symbol)))) + (unintern-existing () + :report (lambda (s) (format s "Unintern ~S and continue" local-sym)) + (unintern local-sym) + (%import symbol)) + (skip () + :report "Skip symbol")))) + T) + From mevenson at common-lisp.net Fri Feb 5 15:52:56 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 05 Feb 2010 10:52:56 -0500 Subject: [armedbear-cvs] r12419 - trunk/abcl Message-ID: Author: mevenson Date: Fri Feb 5 10:52:55 2010 New Revision: 12419 Log: 'abcl.release' target now drives the release process. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Fri Feb 5 10:52:55 2010 @@ -723,6 +723,11 @@ Finished recording test output in ${abcl.test.log.file}. + + + From astalla at common-lisp.net Fri Feb 5 23:19:00 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 05 Feb 2010 18:19:00 -0500 Subject: [armedbear-cvs] r12420 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Fri Feb 5 18:18:57 2010 New Revision: 12420 Log: Tentative inlining of named local function with complex lambda lists; fixed a bug with inline declarations in a flet block that were incorrectly applied to local function declared in the flet, too. 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 Fri Feb 5 18:18:57 2010 @@ -45,16 +45,26 @@ (eval-when (:compile-toplevel :load-toplevel :execute) - (defun generate-inline-expansion (block-name lambda-list body) - (cond ((intersection lambda-list - '(&optional &rest &key &allow-other-keys &aux) - :test #'eq) - nil) - (t - (setf body (copy-tree body)) - (list 'LAMBDA lambda-list - (list* 'BLOCK block-name body))))) - ) ; EVAL-WHEN + (defun generate-inline-expansion (name lambda-list body + &optional (args nil args-p)) + "Generates code that can be used to expand a named local function inline. It can work either per-function (no args provided) or per-call." + (if args-p + (expand-function-call-inline + nil lambda-list + (copy-tree `((block ,name + (locally + (declare (notinline ,name)) + , at body)))) + args) + (cond ((intersection lambda-list + '(&optional &rest &key &allow-other-keys &aux) + :test #'eq) + nil) + (t + (setf body (copy-tree body)) + (list 'LAMBDA lambda-list + (list* 'BLOCK name body)))))) + ) ; EVAL-WHEN ;;; Pass 1. @@ -234,7 +244,7 @@ ;;an unknown keyword. (loop :for var :in arguments :by #'cddr - :for value :in (cdr arguments) by #'cddr + :for value :in (cdr arguments) :by #'cddr :do (let ((var-info (find var key :key #'keyword))) (if (and var-info (not (member var already-seen))) ;;var is one of the declared keyword arguments @@ -290,7 +300,6 @@ (error 'lambda-list-mismatch :mismatch-type :unknown-keyword))) (when rest (setf bindings (append bindings `((,(var rest) (list ,@(nreverse args))))))) - (print bindings) (values bindings temp-bindings ignorables)))) #||test for the above @@ -305,6 +314,20 @@ (jvm::lambda-list-mismatch (x) (jvm::lambda-list-mismatch-type x))) ||# +(defun expand-function-call-inline (form lambda-list body args) + (handler-case + (multiple-value-bind (bindings ignorables) + (match-lambda-list (multiple-value-list + (parse-lambda-list lambda-list)) + args) + `(let* ,bindings + (declare (ignorable , at ignorables)) + , at body)) + (lambda-list-mismatch (x) + (compiler-warn "Invalid function call: ~S (mismatch type: ~A)" + form (lambda-list-mismatch-type x)) + form))) + ;; Returns a list of declared free specials, if any are found. (declaim (ftype (function (list list block-node) list) process-declarations-for-vars)) @@ -887,33 +910,37 @@ (with-local-functions-for-flet/labels form local-functions lambda-list name body ((let ((local-function (make-local-function :name name - :compiland compiland))) + :compiland compiland)) + (definition (cons lambda-list body))) (multiple-value-bind (body decls) (parse-body body) (let* ((block-name (fdefinition-block-name name)) (lambda-expression - (rewrite-lambda - `(lambda ,lambda-list , at decls (block ,block-name , at body)))) + (rewrite-lambda `(lambda ,lambda-list , at decls (block ,block-name , at body)))) (*visible-variables* *visible-variables*) (*local-functions* *local-functions*) (*current-compiland* compiland)) (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)) (p1-compiland compiland))) (push local-function local-functions))) ((with-saved-compiler-policy + (let ((inline-decls *inline-declarations*)) (process-optimization-declarations (cddr form)) - (let* ((block (make-flet-node)) - (*blocks* (cons block *blocks*)) - (body (cddr form)) - (*visible-variables* *visible-variables*)) - (setf (flet-free-specials block) - (process-declarations-for-vars body nil block)) - (dolist (special (flet-free-specials block)) - (push special *visible-variables*)) - (setf (flet-form block) - (list* (car form) local-functions (p1-body (cddr form)))) - block))))) + (let* ((block (make-flet-node)) + (*blocks* (cons block *blocks*)) + (body (cddr form)) + (*visible-variables* *visible-variables*)) + (setf (flet-free-specials block) + (process-declarations-for-vars body nil block)) + (dolist (special (flet-free-specials block)) + (push special *visible-variables*)) + (setf (flet-form block) + (let ((*inline-declarations* inline-decls)) + (list* (car form) local-functions (p1-body (cddr form))))) + block)))))) (defun p1-labels (form) @@ -1224,19 +1251,7 @@ (args (cdr form))) (if (and (listp op) (eq (car op) 'lambda)) - (handler-case - (let ((lambda-list - (multiple-value-list (parse-lambda-list (cadr op)))) - (body (cddr op))) - (multiple-value-bind (bindings ignorables) - (match-lambda-list lambda-list args) - `(let* ,bindings - (declare (ignorable , at ignorables)) - , at body))) - (lambda-list-mismatch (x) - (compiler-warn "Invalid function call: ~S (mismatch type: ~A)" - form (lambda-list-mismatch-type x)) - form)) + (expand-function-call-inline form (cadr op) (cddr op) args) (if (unsafe-p args) (let ((arg1 (car args))) (cond ((and (consp arg1) (eq (car arg1) 'GO)) @@ -1273,14 +1288,19 @@ ;; (format t "p1 local call to ~S~%" op) ;; (format t "inline-p = ~S~%" (inline-p op)) - (when (and *enable-inline-expansion* (inline-p op)) - (let ((expansion (local-function-inline-expansion local-function))) + (when (and *enable-inline-expansion* (inline-p op) + (local-function-definition local-function)) + (let* ((definition (local-function-definition local-function)) + (lambda-list (car definition)) + (body (cdr definition)) + (expansion (generate-inline-expansion op lambda-list body + (cdr form)))) (when expansion (let ((explain *explain*)) (when (and explain (memq :calls explain)) (format t "; inlining call to local function ~S~%" op))) (return-from p1-function-call - (p1 (expand-inline form expansion)))))) + (p1 expansion))))) ;; FIXME (dformat t "local function assumed not single-valued~%") From astalla at common-lisp.net Fri Feb 5 23:26:34 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 05 Feb 2010 18:26:34 -0500 Subject: [armedbear-cvs] r12421 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Fri Feb 5 18:26:33 2010 New Revision: 12421 Log: Missing file from previous commit. Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Fri Feb 5 18:26:33 2010 @@ -355,6 +355,7 @@ (defstruct local-function name + definition compiland inline-expansion function ;; the function loaded through load-compiled-function From mevenson at common-lisp.net Sat Feb 6 10:52:36 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 06 Feb 2010 05:52:36 -0500 Subject: [armedbear-cvs] r12422 - in trunk/abcl: doc/design/pathnames src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat Feb 6 05:52:32 2010 New Revision: 12422 Log: Extensively reworked new implementation for specifiying jar pathnames. Pathname namestrings that have the form "jar:URL!/ENTRY" now construct references to the ENTRY within a jar file that is located by URL. The most common use is the "file:" form of URL (e.g. 'jar:file:/home/me/foo.jar!/foo.lisp') although any valid syntax accepted by the java.net.URL constructor should work (such as 'jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/eek.lisp'). The internal structure of a jar pathname has changed. Previously a pathname with a DEVICE that was itself a pathname referenced a jar. This convention was not able to simultaneously represent bothjar entries that were themselves jar files as occurs with packed FASLs within JARs and devices which refer to drive letters under Windows. Now, a pathname which refers to a jar has a DEVICE which is a proper list of at most two entries. The first entry always references the "outer jar", and the second entry (if it exists) references the "inner jar". Casual users are encouraged not to manipulate the "internal structure" of jar pathname by setting its DEVICE directly, but instead rely on namestring <--> pathname conversions. Jar pathnames are only currently valid for use with LOAD, TRUENAME, PROBE-FILE and pathname translation related functions (such as MERGE-PATHNAMES, TRANSLATE-PATHNAME, etc.) Passing one to OPEN currently signals an error. Jar pathnames do not currently work with DIRECTORY or PROBE-DIRECTORY. Jar pathnames work for ASDF systems packaged within JARs. We override ASDF:LOAD-OP to load ASDF from JAR Pathnames by bypassing compilation if the output location would be in a JAR file. Interaction with ASDF-BINARY-LOCATIONS is currently untested. Pathname now used as the basis of ABCL's internal routines for loading FASLs replacing the use of strings, which simplifies a lot of the behavior in looking for things to LOAD. Fixed nasty shared structure bug on MERGE-PATHNAMES by implementing (and using) a copy constructor for Pathname. Implemented SYS:PATHNAME-JAR-P predicate for jar pathnames. Removed ZipCache as it is no longer used now that we are using JVM's implicit JAR caching. WRITE-FILE-DATE works for jar pathnames, returning 0 for a non-existent entry. JAR-FILE tests now include loading FASLs from network location, which means that these tests will fail if there is no network connectivity. The tests initialization rewritten in Lisp, so it works under Windows. Allow of a top directory for creating hierarchially ZIPs with SYS:ZIP. There is now a three argument version--PATHNAME PATHNAMES &OPTIONAL TOPDIR--whereby all pathnames will be interpolated relative to topdir. Implementation of SYS:UNZIP to unpack ZIP/JAR files. JAR files always use '/' to name hierarchial entries. Pathname translates '/' --> '\' under isPlatformWindows for all hierarchy *except* reference to jar entries. Pathname URL constructor under Windows to properly parses the drive letter. Ensure that *EXT:LISP-HOME* contains a directory. Removed unused imports. Converted Primitives to stack-trace friendly form where we touched the source extensively anyways. Added: trunk/abcl/doc/design/pathnames/ trunk/abcl/doc/design/pathnames/abcl-jar-url.text trunk/abcl/src/org/armedbear/lisp/asdf-abcl.lisp trunk/abcl/src/org/armedbear/lisp/unzip.java Removed: trunk/abcl/src/org/armedbear/lisp/ZipCache.java Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java trunk/abcl/src/org/armedbear/lisp/FileStream.java trunk/abcl/src/org/armedbear/lisp/Interpreter.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/LogicalPathname.java trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/src/org/armedbear/lisp/Site.java trunk/abcl/src/org/armedbear/lisp/Stream.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/Utilities.java trunk/abcl/src/org/armedbear/lisp/asdf.lisp trunk/abcl/src/org/armedbear/lisp/compile-system.lisp trunk/abcl/src/org/armedbear/lisp/file_write_date.java Added: trunk/abcl/doc/design/pathnames/abcl-jar-url.text ============================================================================== --- (empty file) +++ trunk/abcl/doc/design/pathnames/abcl-jar-url.text Sat Feb 6 05:52:32 2010 @@ -0,0 +1,259 @@ +JARs and JAR entries in ABCL +============================ + +Mark Evenson +Created: 09 JAN 2010 +Modified: 24 JAN 2010 + +Notes towards sketching an implementation of "jar:" references to be +contained in PATHNAMEs within ABCL + + +Goals +----- + +1. Use Common Lisp pathnames to refer to entries in a JAR file. + + +2. Use 'jar:' schema as documented in java.net.JarURLConnection for + namestring representation. + +An entry in a JAR file: + #p"jar:file:baz.jar!/foo" + +A JAR file: + #p"jar:file:baz.jar!/" + +A JAR file accessible via URL + #p"jar:http://example.org/abcl.jar!/" + +An entry in a ABCL FASL in a URL accessible JAR file + #p"jar:jar:http://example.org/abcl.jar!/foo.abcl!/foo-1.cls" + +3. MERGE-PATHNAMES working for JAR entries + + (merge-pathnames "foo-1.cls" "jar:jar:file:baz.jar!/foo.abcl!/foo._") + "jar:jar:file:baz.jar!/foo.abcl!/foo-1.cls" + + (merge-pathnames "foo-1.cls" "jar:file:foo.abcl!/") + "jar:file:foo.abcl!/foo-1.cls" + +4. TRUENAME and PROBE-FILE working with "jar:" + +4.1 TRUENAME cannonicalizing the JAR reference. + +5. DIRECTORY working within JAR files (and within JAR in JAR). + +6. References "jar:" for all strings that java.net.URL can + resolve works. + + +Implementation +-------------- + +Using PATHNAMES + +* A PATHNAME refering to a file within a JAR is known as a JAR + PATHNAME. It can either refer to the entire JAR file or an entry + within the JAR file. + +* A JAR PATHNAME always has a DEVICE which is a proper list. This + distinguishes it from other uses of Pathname. + +* The DEVICE of a JAR PATHNAME will be a list with either one or two + elements. The first element of the JAR PATHNAME can be either a + PATHNAME representing a JAR on the filesystem, or a SimpleString + representing a URL. + +* a PATHNAME occuring in the list in the DEVICE of a JAR PATHNAME is + known as a DEVICE PATHNAME. + +* If the DEVICE is a String it must be a String that successfully + constructs a URL via the java.net.URL(String) constructor + +* Only the first entry in the the DEVICE list may be a String. + +* Otherwise the the DEVICE PATHAME denotes the PATHNAME of the JAR file + +* The DEVICE PATHNAME list of enclosing JARs runs from outermost to + innermost. + + + +Use Cases +--------- + +// UC1 -- JAR +pathname: { + namestring: "jar:file:foo/baz.jar!/" + device: ( + pathname: { + device: "jar:file:" + directory: (:RELATIVE "foo") + name: "baz" + type: "jar" + } + ) +} + + +// UC1 -- JAR entry +pathname: { + namestring: "jar:file:baz.jar!/foo.abcl" + device: ( pathname: { + device: "jar:file:" + name: "baz" + type: "jar" + }) + name: "foo" + type: "abcl" +} + + +// UC3 -- JAR file in a JAR entry +pathname: { + namestring: "jar:jar:file:baz.jar!/foo.abcl!/" + device: ( + pathname: { + name: "baz" + type: "jar" + } + pathname: { + name: "foo" + type: "abcl" + } + ) +} + +// UC4 -- JAR entry in a JAR entry with directories +pathname: { + namestring: "jar:jar:file:a/baz.jar!/b/c/foo.abcl!/this/that/foo-20.cls" + device: ( + pathname { + directory: (:RELATIVE "a") + name: "bar" + type: "jar" + } + pathname { + directory: (:RELATIVE "b") + name: "foo" + type: "abcl" + } + ) + directory: (:RELATIVE "this" "that") + name: "foo-20" + type: "cls" +} + +// UC5 -- JAR Entry in a JAR Entry +pathname: { + namestring: "jar:jar:file:a/foo/baz.jar!/foo.abcl!/a/b/bar-1.cls" + device: ( + pathname: { + device: "jar:file:" + name: "baz" + type: "jar" + } + pathname: { + name: "foo" + type: "abcl" + } + ) + name: "bar-1" + type: "cls" +} + +// UC6 -- JAR entry in a http: accessible JAR file +pathname: { + namestring: "jar:http://example.org/abcl.jar!/org/armedbear/lisp/Version.class", + device: ( + "http://example.org/abcl.jar" + pathname: { + directory: (:relative "org" "armedbear" "lisp") + name: "Version" + type: "class" + } +} + +// UC7 -- JAR Entry in a JAR Entry in a URL accessible JAR FILE +pathname: { + namestring "jar:jar:http://example.org/abcl.jar!/foo.abcl!/foo-1.cls" + device: ( + "http://example.org/abcl.jar" + pathname: { + name: "foo" + type: "abcl" + } + ) + name: "foo-1" + type: "cls" +} + +// UC8 -- JAR in an absolute directory + +pathame: { + namestring: "jar:file:/a/b/foo.jar!/" + device: ( + pathname: { + directory: (:ABSOLUTE "a" "b") + name: "foo" + type: "jar" + } + ) +} + +// UC9 -- JAR in an relative directory with entry +pathname: { + namestring: "jar:file:a/b/foo.jar!/c/d/foo.lisp" + device: ( + directory: (:RELATIVE "a" "b") + name: "foo" + type: "jar" + ) + directory: (:RELATIVE "c" "d") + name: "foo" + type: "lisp +} + + + +Problems +-------- + +1. DEVICE PATHNAMES require the context within the nested PATHNAME + structure to be interpreted correctly. + +Result: Be careful when manipulating PATHNAMEs that refer to JARs + + +History +------- + +In the use of PATHNAMEs linked by the DEVICE field, we found the problem +that UNC path support uses the DEVICE field + +Result: JARs located on UNC mounts can't be referenced. via '\\'. + + i.e. jar:jar:file:\\server\share\a\b\foo.jar!/this\that!/foo.java + +would not have + +Solution: Instead of having DEVICE point to a PATHNAME, have DEVICE +be a list of PATHNAMES + +pathname: { + namestring: "jar:jar:file:\\server\share\foo.jar!/foo.abcl!/" + device: ( pathname: { + name: "foo" + type: "abcl" + } + pathname: { + host: "server" + device: "share" + name: "foo" + type: "jar" + } +} + +Which order for the list? Outermost first or last? Outermost first. + Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Sat Feb 6 05:52:32 2010 @@ -667,6 +667,7 @@ autoload(PACKAGE_SYS, "simple-list-remove-duplicates", "simple_list_remove_duplicates"); autoload(PACKAGE_SYS, "single-float-bits", "FloatFunctions", true); autoload(PACKAGE_SYS, "std-allocate-instance", "StandardObjectFunctions", true); + autoload(PACKAGE_SYS, "unzip", "unzip", true); autoload(PACKAGE_SYS, "zip", "zip", true); autoload(PACKAGE_SYS, "proxy-preloaded-function", Modified: trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java (original) +++ trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java Sat Feb 6 05:52:32 2010 @@ -246,69 +246,72 @@ return new JavaObject(new Hashtable()); } - // ### proxy-preloaded-function - final private static Primitive PROXY_PRELOADED_FUNCTION - = new Primitive("proxy-preloaded-function", PACKAGE_SYS, false, - "symbol name") - { - @Override - final public LispObject execute(LispObject symbol, LispObject name) { - LispThread thread = LispThread.currentThread(); - Symbol sym; - Function fun; - FunctionType fType = FunctionType.NORMAL; - - if (symbol instanceof Symbol) - sym = (Symbol)symbol; - else if (isValidSetfFunctionName(symbol)) { - sym = (Symbol)symbol.cadr(); - fType = FunctionType.SETF; - } else if (isValidMacroFunctionName(symbol)) { - sym = (Symbol)symbol.cadr(); - fType = FunctionType.MACRO; - } else { - checkSymbol(symbol); // generate an error - return null; // not reached + // ### proxy-preloaded-function symbol name => function + final private static Primitive PROXY_PRELOADED_FUNCTION = new proxy_preloaded_function(); + final private static class proxy_preloaded_function extends Primitive { + proxy_preloaded_function() { + super("proxy-preloaded-function", PACKAGE_SYS, false, + "symbol name"); } - - LispObject cache = AUTOLOADING_CACHE.symbolValue(thread); - if (cache instanceof Nil) - // during EVAL-WHEN :compile-toplevel, this function will - // be called without a caching environment; we'll need to - // forward to the compiled function loader - return loadCompiledFunction(name.getStringValue()); - else { - LispObject[] cachedSyms = new LispObject[symsToSave.length]; - for (int i = 0; i < symsToSave.length; i++) - cachedSyms[i] = symsToSave[i].symbolValue(thread); - - fun = new AutoloadedFunctionProxy(sym, name, cache, - cachedSyms, fType); - fun.setClassBytes((byte[])((Hashtable)cache.javaInstance()) - .get(name.getStringValue())); + @Override + final public LispObject execute(LispObject symbol, LispObject name) { + LispThread thread = LispThread.currentThread(); + Symbol sym; + Function fun; + FunctionType fType = FunctionType.NORMAL; + + if (symbol instanceof Symbol) + sym = (Symbol)symbol; + else if (isValidSetfFunctionName(symbol)) { + sym = (Symbol)symbol.cadr(); + fType = FunctionType.SETF; + } else if (isValidMacroFunctionName(symbol)) { + sym = (Symbol)symbol.cadr(); + fType = FunctionType.MACRO; + } else { + checkSymbol(symbol); // generate an error + return null; // not reached + } + + LispObject cache = AUTOLOADING_CACHE.symbolValue(thread); + if (cache instanceof Nil) + // during EVAL-WHEN :compile-toplevel, this function will + // be called without a caching environment; we'll need to + // forward to the compiled function loader + return loadCompiledFunction(name.getStringValue()); + else { + LispObject[] cachedSyms = new LispObject[symsToSave.length]; + for (int i = 0; i < symsToSave.length; i++) + cachedSyms[i] = symsToSave[i].symbolValue(thread); + + fun = new AutoloadedFunctionProxy(sym, name, cache, + cachedSyms, fType); + fun.setClassBytes((byte[])((Hashtable)cache.javaInstance()) + .get(name.getStringValue())); + } + return fun; } - - return fun; - } - }; - - // ### function-preload - final private static Primitive FUNCTION_PRELOAD - = new Primitive("function-preload", PACKAGE_SYS, false, "name") - { - @SuppressWarnings("unchecked") - @Override - final public LispObject execute(LispObject name) { - String namestring = name.getStringValue(); - LispThread thread = LispThread.currentThread(); - Hashtable cache - = (Hashtable)AUTOLOADING_CACHE.symbolValue(thread).javaInstance(); - - byte[] bytes = readFunctionBytes(namestring); - cache.put(namestring, bytes); - - return T; } - }; + // ### function-preload name => success + final private static Primitive FUNCTION_PRELOAD = new function_preload(); + private static class function_preload extends Primitive { + function_preload() { + super("function-preload", PACKAGE_SYS, false, "name"); + } + @SuppressWarnings("unchecked") + @Override + final public LispObject execute(LispObject name) { + String namestring = name.getStringValue(); + LispThread thread = LispThread.currentThread(); + Hashtable cache + = (Hashtable)AUTOLOADING_CACHE.symbolValue(thread).javaInstance(); + + Pathname pathname = new Pathname(namestring); + byte[] bytes = readFunctionBytes(pathname); + cache.put(namestring, bytes); + + return T; + } + } } Modified: trunk/abcl/src/org/armedbear/lisp/FileStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FileStream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/FileStream.java Sat Feb 6 05:52:32 2010 @@ -280,12 +280,17 @@ { final Pathname pathname; - if(first instanceof Pathname) { + if (first instanceof Pathname) { pathname = (Pathname) first; } else { return type_error(first, Symbol.PATHNAME); } + if (pathname.isJar()) { + error(new FileError("Direct stream input/output on entries in JAR files no currently supported.", + pathname)); + } + final LispObject namestring = checkString(second); LispObject elementType = third; LispObject direction = fourth; Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Interpreter.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Interpreter.java Sat Feb 6 05:52:32 2010 @@ -285,8 +285,8 @@ if (i + 1 < args.length) { if (arg.equals("--load")) Load.load(new Pathname(args[i + 1]), - args[i + 1], false, false, true); + else Load.loadSystemFile(args[i + 1]); ++i; 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 Sat Feb 6 05:52:32 2010 @@ -1201,134 +1201,63 @@ LispThread.currentThread()); } + @Deprecated public static final LispObject loadCompiledFunction(final String namestring) - { - byte[] bytes = readFunctionBytes(namestring); + Pathname name = new Pathname(namestring); + byte[] bytes = readFunctionBytes(name); if (bytes != null) return loadClassBytes(bytes); return null; } - public static final byte[] readFunctionBytes(final String namestring) - { - final LispThread thread = LispThread.currentThread(); - final boolean absolute = Utilities.isFilenameAbsolute(namestring); - LispObject device = NIL; - final Pathname defaultPathname; - if (absolute) - { - defaultPathname = - coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue(thread)); + public static final byte[] readFunctionBytes(final Pathname name) { + final LispThread thread = LispThread.currentThread(); + Pathname load = null; + LispObject truenameFasl = Symbol.LOAD_TRUENAME_FASL.symbolValue(thread); + LispObject truename = Symbol.LOAD_TRUENAME.symbolValue(thread); + Pathname fasl = null; + if (truenameFasl instanceof Pathname) { + load = Pathname.mergePathnames(name, (Pathname)truenameFasl, Keyword.NEWEST); + } else if (truename instanceof Pathname) { + load = Pathname.mergePathnames(name, (Pathname) truename, Keyword.NEWEST); + } else { + load = name; } - else - { - LispObject loadTruename = Symbol.LOAD_TRUENAME.symbolValue(thread); - if (loadTruename instanceof Pathname) - { - defaultPathname = (Pathname) loadTruename; - // We're loading a file. - device = ((Pathname)loadTruename).getDevice(); - } - else - { - defaultPathname = - coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue(thread)); - } - } - if (device instanceof Pathname) { //Loading from a jar - URL url = null; - String jar = ((Pathname)device).getNamestring(); - if(jar.startsWith("jar:")) { - try { - url = new URL(jar + "!/" + namestring); - } catch (MalformedURLException ex) { - Debug.trace(ex); - } - } else { - url = Lisp.class.getResource(namestring); - } - if (url != null) { - try { - InputStream input = null; - java.io.ByteArrayOutputStream baos = new java.io.ByteArrayOutputStream(); - try { - input = url.openStream(); - byte[] bytes = new byte[4096]; - int n = 0; - while (n >= 0) { - n = input.read(bytes, 0, 4096); - if(n >= 0) { - baos.write(bytes, 0, n); - } - } - bytes = baos.toByteArray(); - return bytes; - } finally { - baos.close(); - if(input != null) { - input.close(); - } - } - } catch (IOException e) { - Debug.trace(e); - } - } - error(new LispError("Unable to load " + namestring)); - return null; // not reached - } - Pathname pathname = new Pathname(namestring); - final File file = Utilities.getFile(pathname, defaultPathname); - if (file != null && file.isFile()) - { - // The .cls file exists. - try - { - byte[] bytes = readFunctionBytes(new FileInputStream(file), - (int) file.length()); - // FIXME close stream! - if (bytes != null) - return bytes; + InputStream input = load.getInputStream(); + byte[] bytes = new byte[4096]; + try { + if (input == null) { + Debug.trace("Pathname: " + name); + Debug.trace("LOAD_TRUENAME_FASL: " + truenameFasl); + Debug.trace("LOAD_TRUENAME: " + truename); + Debug.assertTrue(input != null); } - catch (FileNotFoundException fnf) { - error(new LispError("Unable to load " + pathname.writeToString() - + ": " + fnf.getMessage())); - return null; // not reached - } - return null; // not reached - } - try - { - LispObject loadTruename = Symbol.LOAD_TRUENAME.symbolValue(thread); - String zipFileName = ((Pathname)loadTruename).getNamestring(); - ZipFile zipFile = ZipCache.getZip(zipFileName); - try - { - ZipEntry entry = zipFile.getEntry(namestring); - if (entry != null) - { - byte[] bytes = readFunctionBytes(zipFile.getInputStream(entry), - (int) entry.getSize()); - if (bytes != null) - return bytes; - Debug.trace("Unable to load " + namestring); - error(new LispError("Unable to load " + namestring)); - return null; // not reached - } + + int n = 0; + java.io.ByteArrayOutputStream baos = new java.io.ByteArrayOutputStream(); + try { + while (n >= 0) { + n = input.read(bytes, 0, 4096); + if (n >= 0) { + baos.write(bytes, 0, n); + } + } + } catch (IOException e) { + Debug.trace("Failed to read bytes from " + + "'" + name.getNamestring() + "'"); + return null; } - finally - { - ZipCache.removeZip(zipFile.getName()); + bytes = baos.toByteArray(); + } finally { + try { + input.close(); + } catch (IOException e) { + Debug.trace("Failed to close InputStream: " + e); } } - catch (IOException t) - { - Debug.trace(t); - } - error(new FileError("File not found: " + namestring, - new Pathname(namestring))); - return null; // not reached + return bytes; } public static final Function makeCompiledFunctionFromClass(Class c) { @@ -2395,6 +2324,7 @@ Symbol.LOAD_PRINT.initializeSpecial(NIL); Symbol.LOAD_PATHNAME.initializeSpecial(NIL); Symbol.LOAD_TRUENAME.initializeSpecial(NIL); + Symbol.LOAD_TRUENAME_FASL.initializeSpecial(NIL); Symbol.COMPILE_VERBOSE.initializeSpecial(T); Symbol.COMPILE_PRINT.initializeSpecial(T); Symbol._COMPILE_FILE_PATHNAME_.initializeSpecial(NIL); Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Sat Feb 6 05:52:32 2010 @@ -35,20 +35,9 @@ import static org.armedbear.lisp.Lisp.*; -import java.io.ByteArrayInputStream; -import java.io.ByteArrayOutputStream; -import java.io.File; -import java.io.FileInputStream; -import java.io.FileNotFoundException; import java.io.IOException; import java.io.InputStream; import java.net.URL; -import java.net.URLDecoder; -import java.util.Hashtable; -import java.util.zip.ZipEntry; -import java.util.zip.ZipException; -import java.util.zip.ZipFile; -import java.util.zip.ZipInputStream; /* This file holds ABCL's (FASL and non-FASL) loading behaviours. * @@ -61,209 +50,143 @@ * The FASL loader takes over and retrieves the file being loaded * from the special variable and continues loading from there. * - * Note: In order to prevent re-opening the ZIP file again and again, - * ABCL keeps a cache of opened zip files, which are retrieved to load - * .cls (compiled-function files) from the ZIP while loading the main - * ._ file with FASL loading instructions. */ - public final class Load { public static final LispObject load(String filename) - { final LispThread thread = LispThread.currentThread(); return load(new Pathname(filename), - filename, Symbol.LOAD_VERBOSE.symbolValue(thread) != NIL, Symbol.LOAD_PRINT.symbolValue(thread) != NIL, true); } - - private static final File findLoadableFile(final String filename, - final String dir) - { - File file = new File(dir, filename); - if (!file.isFile()) { - String extension = getExtension(filename); - if (extension == null) { - // No extension specified. Try appending ".lisp" or ".abcl". - File lispFile = new File(dir, filename.concat(".lisp")); - File abclFile = new File(dir, filename.concat(".abcl")); - if (lispFile.isFile() && abclFile.isFile()) { - if (abclFile.lastModified() > lispFile.lastModified()) { - return abclFile; - } else { - return lispFile; - } - } else if (abclFile.isFile()) { - return abclFile; - } else if (lispFile.isFile()) { - return lispFile; + + /** @return Pathname of loadable file based on NAME, or null if + * none can be determined. */ + private static final Pathname findLoadableFile(Pathname name) { + LispObject truename = Pathname.truename(name, false); + if (truename instanceof Pathname) { + Pathname t = (Pathname)truename; + if (t.name != NIL + && t.name != null) { + return t; + } + } + if (name.type == NIL + && (name.name != NIL || name.name != null)) { + Pathname lispPathname = new Pathname(name); + lispPathname.type = new SimpleString("lisp"); + lispPathname.invalidateNamestring(); + LispObject lisp = Pathname.truename(lispPathname, false); + Pathname abclPathname = new Pathname(name); + abclPathname.type = new SimpleString("abcl"); + abclPathname.invalidateNamestring(); + LispObject abcl = Pathname.truename(abclPathname, false); + if (lisp instanceof Pathname && abcl instanceof Pathname) { + lispPathname = (Pathname)lisp; + abclPathname = (Pathname)abcl; + long lispLastModified = lispPathname.getLastModified(); + long abclLastModified = abclPathname.getLastModified(); + if (abclLastModified > lispLastModified) { + return lispPathname; + } else { + return abclPathname; + } + } else if (abcl instanceof Pathname) { + return (Pathname) abcl; + } else if (lisp instanceof Pathname) { + return (Pathname) lisp; + } + } + if (name.isJar()) { + if (name.type.equals(NIL)) { + name.type = COMPILE_FILE_INIT_FASL_TYPE; + name.invalidateNamestring(); + Pathname result = findLoadableFile(name); + if (result != null) { + return result; + } + name.type = new SimpleString(COMPILE_FILE_TYPE); + name.invalidateNamestring(); + result = findLoadableFile(name); + if (result != null) { + return result; } } - } else - return file; // the file exists - return null; // this is the error case: the file does not exist - // no need to check again at the caller + } + return null; } public static final LispObject load(Pathname pathname, - String filename, boolean verbose, boolean print, boolean ifDoesNotExist) { - return load(pathname, filename, verbose, print, ifDoesNotExist, false); + return load(pathname, verbose, print, ifDoesNotExist, false); } - public static final LispObject load(Pathname pathname, - String filename, + public static final LispObject load(final Pathname pathname, boolean verbose, boolean print, boolean ifDoesNotExist, boolean returnLastResult) { - String dir = null; - if (!Utilities.isFilenameAbsolute(filename)) { - dir = coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS - .symbolValue()).getNamestring(); - } - - String zipFileName = null; - String zipEntryName = null; - if (filename.startsWith("jar:file:")) { - String s = new String(filename); - s = s.substring(9); - int index = s.lastIndexOf('!'); - if (index >= 0) { - zipFileName = s.substring(0, index); - zipEntryName = s.substring(index + 1); - if (zipEntryName.length() > 0 && zipEntryName.charAt(0) == '/') - zipEntryName = zipEntryName.substring(1); - if (Utilities.isPlatformWindows) { - if (zipFileName.length() > 0 && zipFileName.charAt(0) == '/') - zipFileName = zipFileName.substring(1); - } - } + Pathname mergedPathname = null; + if (!pathname.isAbsolute() && !pathname.isJar()) { + Pathname pathnameDefaults + = coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue()); + mergedPathname = Pathname.mergePathnames(pathname, pathnameDefaults); } - File file = findLoadableFile(filename, dir); - if (null == file && null == zipFileName) { - if (ifDoesNotExist) - return error(new FileError("File not found: " + filename, pathname)); - else + Pathname truename = findLoadableFile(mergedPathname != null ? mergedPathname : pathname); + + if (truename == null || truename.equals(NIL)) { + if (ifDoesNotExist) { + return error(new FileError("File not found: " + pathname)); + } else { + Debug.trace("Failed to load " + pathname.getNamestring()); return NIL; - } - - if (checkZipFile(file)) { - // Either we are loading a packed FASL (i.e. ZIP with suffix ".abcl") - // Or we are loading from a JAR archive - if (".abcl".equals(getExtension(file.getPath()))) { - // So we adjust the value passed to - // loadFileFromStream() to get any further loading - // within this invocation of LOAD to work properly. - filename = file.getPath(); - } - zipFileName = file.getPath(); - zipEntryName = file.getName(); - } - - String truename = filename; - ZipFile zipfile = null; - - boolean packedFASL = false; - - InputStream in = null; - if (zipFileName != null) { - try { - zipfile = ZipCache.getZip(zipFileName); - } - catch (IOException e) { - return error (new FileError("Zip file not found: " + filename, pathname)); - } - ZipEntry entry = zipfile.getEntry(zipEntryName); - if (null == entry) { - // try appending "._" to base filename - int index = zipEntryName.lastIndexOf('.'); - if (-1 == index) index = zipEntryName.length(); - zipEntryName = zipEntryName.substring(0, index).concat("._"); - entry = zipfile.getEntry(zipEntryName); - } - if (null == entry) { - // try appending ".abcl" to base filename - int index = zipEntryName.lastIndexOf('.'); - if (index == -1) - index = zipEntryName.length(); - zipEntryName = zipEntryName.substring(0, index).concat(".abcl"); - entry = zipfile.getEntry(zipEntryName); - if (entry != null) - packedFASL = true; - } - if (null == entry) { - // Try looking for ".lisp" - int i = zipEntryName.lastIndexOf('.'); - if (i == -1) { - i = zipEntryName.length(); - } - zipEntryName = zipEntryName.substring(0, i).concat(".lisp"); - entry = zipfile.getEntry(zipEntryName); - if (entry == null) { - return error(new LispError("Failed to find " + zipEntryName + " in " - + zipFileName + ".")); - } } + } - if (null == entry) { - return error(new FileError("Can't find zip file entry " - + zipEntryName, pathname)); - } - if (".abcl".equals(getExtension(zipEntryName))) { - packedFASL = true; - } - if (packedFASL) { - // If we are loading a packed FASL from the JAR we - // have to decompress it first, and seek for the '._' - // init FASL. - int i = zipEntryName.lastIndexOf('.'); - int j = zipEntryName.lastIndexOf('/'); - if(j >= i) { - return error(new LispError("Invalid zip entry name: " + zipEntryName)); - } - String subZipEntryName = zipEntryName.substring(j + 1, i).concat("._"); - in = Utilities.getZippedZipEntryAsInputStream(zipfile, - zipEntryName, - subZipEntryName); - } else { - try { - in = zipfile.getInputStream(entry); + if (truename.type.getStringValue().equals(COMPILE_FILE_TYPE) + && Utilities.checkZipFile(truename)) + { + String n = truename.getNamestring(); + if (n.startsWith("jar:")) { + n = "jar:" + n + "!/" + truename.name.getStringValue() + "." + + COMPILE_FILE_INIT_FASL_TYPE; + } else { + n = "jar:file:" + n + "!/" + truename.name.getStringValue() + "." + + COMPILE_FILE_INIT_FASL_TYPE; } - catch (IOException e) { - return error(new LispError(e.getMessage())); + mergedPathname = new Pathname(n); + LispObject initTruename = Pathname.truename(mergedPathname); + if (initTruename == null || initTruename.equals(NIL)) { + String errorMessage + = "Loadable FASL not found for" + + "'" + pathname + "'" + + " in " + + "'" + mergedPathname + "'"; + if (ifDoesNotExist) { + return error(new FileError(errorMessage, mergedPathname)); + } else { + Debug.trace(errorMessage); + return NIL; + } } + truename = (Pathname)initTruename; } - } else { - try { - in = new FileInputStream(file); - truename = file.getCanonicalPath(); - } - catch (FileNotFoundException e) { - if (ifDoesNotExist) - return error(new FileError("File not found: " + filename, - pathname)); - else - return NIL; - } - catch (IOException e) { - return error(new LispError(e.getMessage())); - } - } + + InputStream in = truename.getInputStream(); + Debug.assertTrue(in != null); + try { - - return loadFileFromStream(null, truename, - new Stream(Symbol.SYSTEM_STREAM, in, Symbol.CHARACTER), - verbose, print, false, returnLastResult); + return loadFileFromStream(pathname, truename, + new Stream(Symbol.SYSTEM_STREAM, in, Symbol.CHARACTER), + verbose, print, false, returnLastResult); } catch (FaslVersionMismatch e) { FastStringBuffer sb = @@ -280,14 +203,6 @@ return error(new LispError(e.getMessage())); } } - if (zipfile != null) { - try { - ZipCache.removeZip(zipfile.getName()); - } - catch (IOException e) { - return error(new LispError(e.getMessage())); - } - } } } @@ -327,124 +242,86 @@ } } + static final LispObject COMPILE_FILE_INIT_FASL_TYPE = new SimpleString("_"); + public static final LispObject loadSystemFile(final String filename, boolean verbose, boolean print, boolean auto) { - final int ARRAY_SIZE = 2; - String[] candidates = new String[ARRAY_SIZE]; - final String extension = getExtension(filename); - if (extension == null) { - // No extension specified. - candidates[0] = filename + '.' + COMPILE_FILE_TYPE; - candidates[1] = filename.concat(".lisp"); - } else if (extension.equals(".abcl")) { - candidates[0] = filename; - candidates[1] = - filename.substring(0, filename.length() - 5).concat(".lisp"); - } else - candidates[0] = filename; InputStream in = null; Pathname pathname = null; - String truename = null; - for (int i = 0; i < ARRAY_SIZE; i++) { - String s = candidates[i]; - if (s == null) - break; - ZipFile zipfile = null; - final String dir = Site.getLispHome(); + Pathname truename = null; + pathname = new Pathname(filename); + Pathname mergedPathname = Pathname.mergePathnames(pathname, Site.getLispHome()); + truename = findLoadableFile(mergedPathname); + if (truename == null || truename.equals(NIL)) { + // Make an attempt to use the boot classpath + String path = pathname.asEntryPath(); + URL url = Lisp.class.getResource(path); + if (url == null || url.toString().endsWith("/")) { + url = Lisp.class.getResource(path + ".abcl"); + if (url == null) { + url = Lisp.class.getResource(path + ".lisp"); + } + } + if (url == null) { + return error(new LispError("Failed to find loadable system file " + + "'" + path + "'" + + " in boot classpath.")); + } + Pathname urlPathname = new Pathname(url); + truename = findLoadableFile(urlPathname); + if (truename == null) { + return error(new LispError("Failed to find loadable system file in boot classpath " + + "'" + url + "'")); + } + } + + // Look for a init FASL inside a packed FASL + if (truename.type.writeToString().equals(COMPILE_FILE_TYPE) && Utilities.checkZipFile(truename)) { + Pathname init = new Pathname(truename.getNamestring()); + init.type = COMPILE_FILE_INIT_FASL_TYPE; + LispObject t = Pathname.truename(init); + if (t instanceof Pathname) { + truename = (Pathname)t; + } else { + return error (new LispError("Failed to find loadable init FASL in " + + "'" + init.getNamestring() + "'")); + } + } + + in = truename.getInputStream(); + + if (in != null) { + final LispThread thread = LispThread.currentThread(); + final SpecialBindingsMark mark = thread.markSpecialBindings(); + thread.bindSpecial(_WARN_ON_REDEFINITION_, NIL); try { - if (dir != null) { - File file = new File(dir, s); - if (file.isFile()) { - // File exists. For system files, we know the extension - // will be .abcl if it is a compiled file. - String ext = getExtension(s); - if (ext.equalsIgnoreCase(".abcl")) { - try { - zipfile = ZipCache.getZip(file.getPath()); - String name = file.getName(); - int index = name.lastIndexOf('.'); - Debug.assertTrue(index >= 0); - name = name.substring(0, index).concat("._"); - ZipEntry entry = zipfile.getEntry(name); - if (entry != null) { - in = zipfile.getInputStream(entry); - truename = file.getCanonicalPath(); - } - } - catch (ZipException e) { - // Fall through. - } - catch (IOException e) { - // fall through - } - } - if (in == null) { - try { - in = new FileInputStream(file); - truename = file.getCanonicalPath(); - } - catch (IOException e) { - in = null; - } - } - } - } else { - URL url = Lisp.class.getResource(s); - if (url != null) { - try { - in = url.openStream(); - if ("jar".equals(url.getProtocol()) && - url.getPath().startsWith("file:")) - pathname = new Pathname(url); - truename = getPath(url); - } - catch (IOException e) { - in = null; - } - } - } - if (in != null) { - final LispThread thread = LispThread.currentThread(); - final SpecialBindingsMark mark = thread.markSpecialBindings(); - thread.bindSpecial(_WARN_ON_REDEFINITION_, NIL); - try { - return loadFileFromStream(pathname, truename, - new Stream(Symbol.SYSTEM_STREAM, in, Symbol.CHARACTER), - verbose, print, auto); - } - catch (FaslVersionMismatch e) { - FastStringBuffer sb = - new FastStringBuffer("; Incorrect fasl version: "); - sb.append(truename); - System.err.println(sb.toString()); - } - finally { - thread.resetSpecialBindings(mark); - try { - in.close(); - } - catch (IOException e) { - return error(new LispError(e.getMessage())); - } - } + Stream stream = new Stream(Symbol.SYSTEM_STREAM, in, Symbol.CHARACTER); + return loadFileFromStream(pathname, truename, stream, + verbose, print, auto); + } catch (FaslVersionMismatch e) { + FastStringBuffer sb = + new FastStringBuffer("; Incorrect fasl version: "); + sb.append(truename); + System.err.println(sb.toString()); + } finally { + thread.resetSpecialBindings(mark); + try { + in.close(); } - } - finally { - if (zipfile != null) { - try { - ZipCache.removeZip(zipfile.getName()); - } - catch (IOException e) { - return error(new LispError(e.getMessage())); - } + catch (IOException e) { + return error(new LispError(e.getMessage())); } } } - return error(new LispError("File not found: " + filename)); + return error(new FileError("Failed to load system file: " + + "'" + filename + "'" + + " resolved as " + + "'" + mergedPathname + "'" , + truename)); } // ### *fasl-version* @@ -468,10 +345,12 @@ public static final Symbol _FASL_ANONYMOUS_PACKAGE_ = internSpecial("*FASL-ANONYMOUS-PACKAGE*", PACKAGE_SYS, NIL); - // ### init-fasl - private static final Primitive INIT_FASL = - new Primitive("init-fasl", PACKAGE_SYS, true, "&key version") - { + // ### init-fasl &key version + private static final Primitive INIT_FASL = new init_fasl(); + private static class init_fasl extends Primitive { + init_fasl() { + super("init-fasl", PACKAGE_SYS, true, "&key version"); + } @Override public LispObject execute(LispObject first, LispObject second) @@ -487,10 +366,10 @@ } throw new FaslVersionMismatch(second); } - }; + } - private static final LispObject loadFileFromStream(LispObject pathname, - String truename, + private static final LispObject loadFileFromStream(Pathname pathname, + Pathname truename, Stream in, boolean verbose, boolean print, @@ -499,8 +378,9 @@ return loadFileFromStream(pathname, truename, in, verbose, print, auto, false); } + // A nil TRUENAME signals a load from stream which has no possible path private static final LispObject loadFileFromStream(LispObject pathname, - String truename, + LispObject truename, Stream in, boolean verbose, boolean print, @@ -525,12 +405,35 @@ thread.bindSpecialToCurrentValue(_EXPLAIN_); final String prefix = getLoadVerbosePrefix(loadDepth); try { - if (pathname == null && truename != null) - pathname = Pathname.parseNamestring(truename); - thread.bindSpecial(Symbol.LOAD_PATHNAME, - pathname != null ? pathname : NIL); - thread.bindSpecial(Symbol.LOAD_TRUENAME, - pathname != null ? pathname : NIL); + thread.bindSpecial(Symbol.LOAD_PATHNAME, pathname); + Pathname truePathname = new Pathname(((Pathname)truename).getNamestring()); + String type = truePathname.type.getStringValue(); + if (type.equals(COMPILE_FILE_TYPE) + || type.equals(COMPILE_FILE_INIT_FASL_TYPE.toString())) { + thread.bindSpecial(Symbol.LOAD_TRUENAME_FASL, truePathname); + } + if (truePathname.type.getStringValue().equals(COMPILE_FILE_INIT_FASL_TYPE.getStringValue()) + && truePathname.isJar()) { + if (truePathname.device.cdr() != NIL ) { + // set truename to the enclosing JAR + truePathname.host = NIL; + truePathname.directory = NIL; + truePathname.name = NIL; + truePathname.type = NIL; + truePathname.invalidateNamestring(); + } else { + // XXX There is something fishy in the asymmetry + // between the "jar:jar:http:" and "jar:jar:file:" + // cases but this currently passes the tests. + if (!(truePathname.device.car() instanceof AbstractString)) { + truePathname = (Pathname)truePathname.device.car(); + truePathname.invalidateNamestring(); + } + } + thread.bindSpecial(Symbol.LOAD_TRUENAME, truePathname); + } else { + thread.bindSpecial(Symbol.LOAD_TRUENAME, truename); + } thread.bindSpecial(_SOURCE_, pathname != null ? pathname : NIL); if (verbose) { @@ -538,7 +441,7 @@ out.freshLine(); out._writeString(prefix); out._writeString(auto ? " Autoloading " : " Loading "); - out._writeString(truename != null ? truename : "stream"); + out._writeString(!truename.equals(NIL) ? truePathname.writeToString() : "stream"); out._writeLine(" ..."); out._finishOutput(); LispObject result = loadStream(in, print, thread, returnLastResult); @@ -546,7 +449,7 @@ out.freshLine(); out._writeString(prefix); out._writeString(auto ? " Autoloaded " : " Loaded "); - out._writeString(truename != null ? truename : "stream"); + out._writeString(!truename.equals(NIL) ? truePathname.writeToString() : "stream"); out._writeString(" ("); out._writeString(String.valueOf(((float)elapsed)/1000)); out._writeLine(" seconds)"); @@ -610,7 +513,6 @@ } private static final LispObject faslLoadStream(LispThread thread) - { Stream in = (Stream) _LOAD_STREAM_.symbolValue(thread); final Environment env = new Environment(); @@ -638,91 +540,36 @@ //whether to return T or the last value. } - // Returns extension including leading '.' - private static final String getExtension(String filename) - { - int index = filename.lastIndexOf('.'); - if (index < 0) - return null; - if (index < filename.lastIndexOf(File.separatorChar)) - return null; // Last dot was in path part of filename. - return filename.substring(index); - } - - private static final String getPath(URL url) - { - if (url != null) { - String path; - try { - path = URLDecoder.decode(url.getPath(),"UTF-8"); - } - catch (java.io.UnsupportedEncodingException uee) { - // Can't happen: every Java is supposed to support - // at least UTF-8 encoding - path = null; - } - if (path != null) { - if (Utilities.isPlatformWindows) { - if (path.length() > 0 && path.charAt(0) == '/') - path = path.substring(1); - } - return path; - } - } - return null; - } - - private static final boolean checkZipFile(File file) - { - InputStream in = null; - try { - in = new FileInputStream(file); - byte[] bytes = new byte[4]; - int bytesRead = in.read(bytes); - return (bytesRead == 4 - && bytes[0] == 0x50 - && bytes[1] == 0x4b - && bytes[2] == 0x03 - && bytes[3] == 0x04); - } - catch (Throwable t) { // any error probably means 'no' - return false; - } - finally { - if (in != null) { - try { - in.close(); - } - catch (IOException e) {} // ignore exceptions - } - } - } // ### %load filespec verbose print if-does-not-exist => generalized-boolean - private static final Primitive _LOAD = - new Primitive("%load", PACKAGE_SYS, false, - "filespec verbose print if-does-not-exist") - { + private static final Primitive _LOAD = new _load(); + private static class _load extends Primitive { + _load() { + super("%load", PACKAGE_SYS, false, + "filespec verbose print if-does-not-exist"); + } @Override public LispObject execute(LispObject filespec, LispObject verbose, LispObject print, LispObject ifDoesNotExist) - { + { return load(filespec, verbose, print, ifDoesNotExist, NIL); } - }; + } // ### %load-returning-last-result filespec verbose print if-does-not-exist => object - private static final Primitive _LOAD_RETURNING_LAST_RESULT = - new Primitive("%load-returning-last-result", PACKAGE_SYS, false, - "filespec verbose print if-does-not-exist") - { + private static final Primitive _LOAD_RETURNING_LAST_RESULT = new _load_returning_last_result(); + private static class _load_returning_last_result extends Primitive { + _load_returning_last_result() { + super("%load-returning-last-result", PACKAGE_SYS, false, + "filespec verbose print if-does-not-exist"); + } @Override public LispObject execute(LispObject filespec, LispObject verbose, LispObject print, LispObject ifDoesNotExist) { return load(filespec, verbose, print, ifDoesNotExist, T); } - }; + } private static final LispObject load(LispObject filespec, LispObject verbose, @@ -737,11 +584,11 @@ pathname = ((FileStream)filespec).getPathname(); else pathname = NIL; - String truename; + LispObject truename; if (pathname instanceof Pathname) - truename = ((Pathname)pathname).getNamestring(); + truename = pathname; else - truename = null; + truename = NIL; return loadFileFromStream(pathname, truename, (Stream) filespec, @@ -756,7 +603,6 @@ if (pathname instanceof LogicalPathname) pathname = LogicalPathname.translateLogicalPathname((LogicalPathname)pathname); return load(pathname, - pathname.getNamestring(), verbose != NIL, print != NIL, ifDoesNotExist != NIL, @@ -764,9 +610,11 @@ } // ### load-system-file - private static final Primitive LOAD_SYSTEM_FILE = - new Primitive("load-system-file", PACKAGE_SYS, true) - { + private static final Primitive LOAD_SYSTEM_FILE = new load_system_file(); + private static class load_system_file extends Primitive { + load_system_file () { + super("load-system-file", PACKAGE_SYS, true); + } @Override public LispObject execute(LispObject arg) { @@ -776,7 +624,7 @@ Symbol.LOAD_PRINT.symbolValue(thread) != NIL, false); } - }; + } private static class FaslVersionMismatch extends Error { Modified: trunk/abcl/src/org/armedbear/lisp/LogicalPathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LogicalPathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LogicalPathname.java Sat Feb 6 05:52:32 2010 @@ -45,10 +45,14 @@ private static final HashMap map = new HashMap(); - public LogicalPathname() + protected LogicalPathname() { } + protected LogicalPathname(Pathname p) { + super(p); + } + public LogicalPathname(String host, String rest) { final int limit = rest.length(); @@ -278,28 +282,31 @@ } // ### canonicalize-logical-host host => canonical-host - private static final Primitive CANONICALIZE_LOGICAL_HOST = - new Primitive("canonicalize-logical-host", PACKAGE_SYS, true, "host") - { + private static final Primitive CANONICALIZE_LOGICAL_HOST = new canonicalize_logical_host(); + private static class canonicalize_logical_host extends Primitive { + canonicalize_logical_host() { + super("canonicalize-logical-host", PACKAGE_SYS, true, "host"); + } @Override public LispObject execute(LispObject arg) - { - AbstractString s = checkString(arg); - if (s.length() == 0) { - // "The null string, "", is not a valid value for any - // component of a logical pathname." 19.3.2.2 - return error(new LispError("Invalid logical host name: \"" + - s.getStringValue() + '"')); - } - return canonicalizeStringComponent(s); + AbstractString s = checkString(arg); + if (s.length() == 0) { + // "The null string, "", is not a valid value for any + // component of a logical pathname." 19.3.2.2 + return error(new LispError("Invalid logical host name: \"" + + s.getStringValue() + '"')); + } + return canonicalizeStringComponent(s); } - }; + } // ### %make-logical-pathname namestring => logical-pathname - private static final Primitive _MAKE_LOGICAL_PATHNAME = - new Primitive("%make-logical-pathname", PACKAGE_SYS, true, "namestring") - { + private static final Primitive _MAKE_LOGICAL_PATHNAME = new _make_logical_pathname(); + private static class _make_logical_pathname extends Primitive { + _make_logical_pathname() { + super("%make-logical-pathname", PACKAGE_SYS, true, "namestring"); + } @Override public LispObject execute(LispObject arg) @@ -321,5 +328,5 @@ } return error(new TypeError("Logical namestring does not specify a host: \"" + s + '"')); } - }; + } } 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 Sat Feb 6 05:52:32 2010 @@ -30,93 +30,169 @@ * 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.*; import java.io.File; import java.io.IOException; +import java.io.InputStream; +import java.io.FileInputStream; +import java.net.JarURLConnection; +import java.net.MalformedURLException; import java.net.URL; +import java.net.URLConnection; import java.net.URLDecoder; import java.util.StringTokenizer; +import java.util.jar.JarEntry; +import java.util.jar.JarFile; +import java.util.zip.ZipEntry; +import java.util.zip.ZipInputStream; + +public class Pathname extends LispObject { -public class Pathname extends LispObject -{ protected LispObject host = NIL; protected LispObject device = NIL; protected LispObject directory = NIL; protected LispObject name = NIL; - // A string, NIL, :WILD or :UNSPECIFIC. protected LispObject type = NIL; - // A positive integer, or NIL, :WILD, :UNSPECIFIC, or :NEWEST. protected LispObject version = NIL; private String namestring; - protected Pathname() - { + /** The protocol for changing any instance field (i.e. 'host', 'type', etc.) + * is to call this method after changing the field to recompute the namestring. + * We could do this with setter/getters, but that choose not to in order to avoid the + * performance indirection penalty. + */ + public void invalidateNamestring() { + namestring = null; + } + + protected Pathname() {} + + /** Copy constructor which shares no structure with the original. */ + protected Pathname(Pathname p) { + if (p.host != NIL) { + if (p.host instanceof SimpleString) { + host = new SimpleString(((SimpleString)p.host).getStringValue()); + } else if (p.host instanceof Symbol) { + host = p.host; + } else { + Debug.assertTrue(false); + } + } + if (p.device != NIL) { + if (p.device instanceof SimpleString) { + device = new SimpleString(((SimpleString)p.device).getStringValue()); + } else if (p.device instanceof Cons) { + Cons jars = (Cons)p.device; + device = new Cons(NIL, NIL); + LispObject first = jars.car(); + if (first instanceof SimpleString) { + ((Cons)device).car = new SimpleString(((SimpleString)first).getStringValue()); + } else if (first instanceof Pathname) { + ((Cons)device).car = new Pathname((Pathname)first); + } else { + Debug.assertTrue(false); + } + if (!jars.cdr().equals(NIL)) { + if (jars.cdr() instanceof Cons) { + ((Cons)device).cdr = new Cons(new Pathname((Pathname)jars.cdr().car()), NIL); + } else { + Debug.assertTrue(false); + } + } + } else if (p.device instanceof Symbol) { + device = p.device; + } else { + Debug.assertTrue(false); + } + } + if (p.directory != NIL) { + if (p.directory instanceof Cons) { + directory = NIL; + for (LispObject list = p.directory; list != NIL; list = list.cdr()) { + LispObject o = list.car(); + if (o instanceof Symbol) { + directory = directory.push(o); + } else if (o instanceof SimpleString) { + directory = directory.push(new SimpleString(((SimpleString)o).getStringValue())); + } else { + Debug.assertTrue(false); + } + } + directory.nreverse(); + } else { + Debug.assertTrue(false); + } + } + if (p.name != NIL) { + if (p.name instanceof SimpleString) { + name = new SimpleString(((SimpleString)p.name).getStringValue()); + } else if (p.name instanceof Symbol) { + name = p.name; + } else { + Debug.assertTrue(false); + } + } + if (p.type != NIL) { + if (p.type instanceof SimpleString) { + type = new SimpleString(((SimpleString)p.type).getStringValue()); + } else if (p.type instanceof Symbol) { + type = p.type; + } else { + Debug.assertTrue(false); + } + } } - public Pathname(String s) - { + public Pathname(String s) { init(s); } - public Pathname(URL url) - { + public Pathname(URL url) { String protocol = url.getProtocol(); if ("jar".equals(protocol)) { - String s; - try { - s = URLDecoder.decode(url.getPath(),"UTF-8"); - } - catch (java.io.UnsupportedEncodingException uee) { - // Can't happen: every Java is supposed to support - // at least UTF-8 encoding - s = null; - } - if (s.startsWith("file:")) { - int index = s.indexOf("!/"); - String container = s.substring(5, index); - if (Utilities.isPlatformWindows) { - if (container.length() > 0 && container.charAt(0) == '/') - container = container.substring(1); - } - device = new Pathname(container); - s = s.substring(index + 1); - Pathname p = new Pathname(s); - directory = p.directory; - name = p.name; - type = p.type; - return; - } + init(url.toString()); + return; } else if ("file".equals(protocol)) { String s; try { - s = URLDecoder.decode(url.getPath(),"UTF-8"); - } - catch (java.io.UnsupportedEncodingException uee) { + s = URLDecoder.decode(url.getPath(), "UTF-8"); + } catch (java.io.UnsupportedEncodingException uee) { // Can't happen: every Java is supposed to support // at least UTF-8 encoding + Debug.assertTrue(false); s = null; } - if (s != null && s.startsWith("file:")) { - init(s.substring(5)); + if (s != null) { + if (Utilities.isPlatformWindows) { + // Workaround for Java's idea of URLs + // new (URL"file:///c:/a/b").getPath() --> "/c:/a/b" + // whereas we need "c" to be the DEVICE. + if (s.length() > 2 + && s.charAt(0) == '/' + && s.charAt(2) == ':') { + s = s.substring(1); + } + } + init(s); return; } } - error(new LispError("Unsupported URL: \"" + url.toString() + '"')); + error(new LispError("Unsupported URL: '" + url.toString() + "'")); } - private final void init(String s) - { - if (s == null) + static final private String jarSeparator = "!/"; + private final void init(String s) { + if (s == null) { return; - if (s.equals(".") || s.equals("./") || - (Utilities.isPlatformWindows && s.equals(".\\"))) { + } + if (s.equals(".") || s.equals("./") + || (Utilities.isPlatformWindows && s.equals(".\\"))) { directory = new Cons(Keyword.RELATIVE); return; } @@ -126,50 +202,130 @@ } if (Utilities.isPlatformWindows) { if (s.startsWith("\\\\")) { - //UNC path support - // match \\\\[directories-and-files] + //UNC path support + // match \\\\[directories-and-files] - int shareIndex = s.indexOf('\\', 2); - int dirIndex = s.indexOf('\\', shareIndex + 1); + int shareIndex = s.indexOf('\\', 2); + int dirIndex = s.indexOf('\\', shareIndex + 1); - if (shareIndex == -1 || dirIndex == -1) - error(new LispError("Unsupported UNC path format: \"" + s + '"')); + if (shareIndex == -1 || dirIndex == -1) { + error(new LispError("Unsupported UNC path format: \"" + s + '"')); + } - host = new SimpleString(s.substring(2, shareIndex)); - device = new SimpleString(s.substring(shareIndex + 1, dirIndex)); - - Pathname p = new Pathname(s.substring(dirIndex)); - directory = p.directory; - name = p.name; - type = p.type; - version = p.version; - return; - } - - s = s.replace('/', '\\'); - } - // Jar file support. - int bang = s.indexOf("!/"); - if (bang >= 0) { - Pathname container = new Pathname(s.substring(0, bang)); - LispObject containerType = container.type; - if (containerType instanceof AbstractString) { - if (containerType.getStringValue().equalsIgnoreCase("jar")) { - device = container; - s = s.substring(bang + 1); - Pathname p = new Pathname(s); - directory = p.directory; - name = p.name; - type = p.type; - return; + host = new SimpleString(s.substring(2, shareIndex)); + device = new SimpleString(s.substring(shareIndex + 1, dirIndex)); + + Pathname p = new Pathname(s.substring(dirIndex)); + directory = p.directory; + name = p.name; + type = p.type; + version = p.version; + return; + } + } + + // A JAR file + if (s.startsWith("jar:") && s.endsWith(jarSeparator)) { + LispObject jars = NIL; + int i = s.lastIndexOf(jarSeparator, s.length() - jarSeparator.length() - 1); + String jar = null; + if (i == -1) { + jar = s; + } else { + // There can be no more than two jar references and the + // inner one must be a file reference within the outer. + jar = "jar:file:" + s.substring(i + jarSeparator.length()); + s = s.substring("jar:".length(), i + jarSeparator.length()); + Pathname p = new Pathname(s); + LispObject first = ((Cons) p.device).car(); + if (first instanceof AbstractString) { + jars = jars.push(first); + } else { + jars = jars.push(p.device.car()); + } + } + if (jar.startsWith("jar:file:")) { + String jarString = jar.substring("jar:".length(), + jar.length() - jarSeparator.length()); + // Use URL constructor to normalize Windows' use of device + URL url = null; + try { + url = new URL(jarString); + } catch (MalformedURLException e) { + error(new LispError("Failed to parse '" + jarString + "'" + + " as URL:" + + e.getMessage())); + } + Pathname jarPathname = new Pathname(url); + if (jarString.endsWith(jarSeparator)) { + jars = jars.push(jarPathname.device); + } else { + jars = jars.push(jarPathname); } + } else { + URL url = null; + try { + url = new URL(jar.substring("jar:".length(), jar.length() - 2)); + jars = jars.push(new SimpleString(url.toString())); + } catch (MalformedURLException e) { + error(new LispError("Failed to parse url '" + url + "'" + + e.getMessage())); + } + } + jars = jars.nreverse(); + device = jars; + return; + } + + // An entry in a JAR file + final int separatorIndex = s.lastIndexOf(jarSeparator); + if (separatorIndex > 0 && s.startsWith("jar:")) { + final String jarURL = s.substring(0, separatorIndex + jarSeparator.length()); + Pathname d = new Pathname(jarURL); + if (device instanceof Cons) { + LispObject[] jars = d.copyToArray(); + // XXX Is this ever reached? If so, need to append lists + Debug.assertTrue(false); + } else { + device = d.device; + } + s = s.substring(separatorIndex + jarSeparator.length()); + Pathname p = new Pathname(s); + directory = p.directory; + name = p.name; + type = p.type; + version = p.version; + return; + } + + if (Utilities.isPlatformWindows) { + if (!s.contains(jarSeparator)) { + s = s.replace("/", "\\"); + } else { + StringBuilder result = new StringBuilder(); + for (int i = 0; i < s.length(); i++) { + char c = s.charAt(i); + if ( c != '/') { + result.append(c); + } else { + if (i != 0 && s.charAt(i-1) != '!') { + result.append("\\"); + } else { + result.append(c); + } + } + } + s = result.toString(); } } + + // Expand user home directories if (Utilities.isPlatformUnix) { - if (s.equals("~")) + if (s.equals("~")) { s = System.getProperty("user.home").concat("/"); - else if (s.startsWith("~/")) + } else if (s.startsWith("~/")) { s = System.getProperty("user.home").concat(s.substring(1)); + } } namestring = s; if (Utilities.isPlatformWindows) { @@ -215,56 +371,59 @@ if (index > 0) { n = s.substring(0, index); t = s.substring(index + 1); - } else if (s.length() > 0) + } else if (s.length() > 0) { n = s; + } if (n != null) { - if (n.equals("*")) + if (n.equals("*")) { name = Keyword.WILD; - else + } else { name = new SimpleString(n); + } } if (t != null) { - if (t.equals("*")) + if (t.equals("*")) { type = Keyword.WILD; - else + } else { type = new SimpleString(t); + } } } - private static final LispObject parseDirectory(String d) - - { - if (d.equals("/") || (Utilities.isPlatformWindows && d.equals("\\"))) + private static final LispObject parseDirectory(String d) { + if (d.equals("/") || (Utilities.isPlatformWindows && d.equals("\\"))) { return new Cons(Keyword.ABSOLUTE); + } LispObject result; - if (d.startsWith("/") || (Utilities.isPlatformWindows && d.startsWith("\\"))) + if (d.startsWith("/") || (Utilities.isPlatformWindows && d.startsWith("\\"))) { result = new Cons(Keyword.ABSOLUTE); - else + } else { result = new Cons(Keyword.RELATIVE); + } StringTokenizer st = new StringTokenizer(d, "/\\"); while (st.hasMoreTokens()) { String token = st.nextToken(); LispObject obj; - if (token.equals("*")) + if (token.equals("*")) { obj = Keyword.WILD; - else if (token.equals("**")) + } else if (token.equals("**")) { obj = Keyword.WILD_INFERIORS; - else if (token.equals("..")) { + } else if (token.equals("..")) { if (result.car() instanceof AbstractString) { result = result.cdr(); continue; } - obj= Keyword.UP; - } else + obj = Keyword.UP; + } else { obj = new SimpleString(token); + } result = new Cons(obj, result); } return result.nreverse(); } @Override - public LispObject getParts() - { + public LispObject getParts() { LispObject parts = NIL; parts = parts.push(new Cons("HOST", host)); parts = parts.push(new Cons("DEVICE", device)); @@ -276,42 +435,41 @@ } @Override - public LispObject typeOf() - { + public LispObject typeOf() { return Symbol.PATHNAME; } @Override - public LispObject classOf() - { + public LispObject classOf() { return BuiltInClass.PATHNAME; } @Override - public LispObject typep(LispObject type) - { - if (type == Symbol.PATHNAME) + public LispObject typep(LispObject type) { + if (type == Symbol.PATHNAME) { return T; - if (type == BuiltInClass.PATHNAME) + } + if (type == BuiltInClass.PATHNAME) { return T; + } return super.typep(type); } - public final LispObject getDevice() - { + public final LispObject getDevice() { return device; } - public String getNamestring() - { - if (namestring != null) + public String getNamestring() { + if (namestring != null) { return namestring; + } if (name == NIL && type != NIL) { Debug.assertTrue(namestring == null); return null; } - if (directory instanceof AbstractString) + if (directory instanceof AbstractString) { Debug.assertTrue(false); + } FastStringBuffer sb = new FastStringBuffer(); // "If a pathname is converted to a namestring, the symbols NIL and // :UNSPECIFIC cause the field to be treated as if it were empty. That @@ -319,26 +477,51 @@ // the namestring." 19.2.2.2.3.1 if (host != NIL) { Debug.assertTrue(host instanceof AbstractString); - if (! (this instanceof LogicalPathname)) - sb.append("\\\\"); //UNC file support; if there's a host, it's a UNC path. + if (!(this instanceof LogicalPathname)) { + sb.append("\\\\"); //UNC file support; if there's a host, it's a UNC path. + } sb.append(host.getStringValue()); - if (this instanceof LogicalPathname) - sb.append(':'); - else - sb.append(File.separatorChar); + if (this instanceof LogicalPathname) { + sb.append(':'); + } else { + sb.append(File.separatorChar); + } } if (device == NIL) { } else if (device == Keyword.UNSPECIFIC) { + } else if (device instanceof Cons) { + LispObject[] jars = ((Cons) device).copyToArray(); + int i = 0; + if (jars[0] instanceof AbstractString) { + sb.append("jar:"); + sb.append(((AbstractString) jars[0]).getStringValue()); + sb.append("!/"); + i = 1; + } + FastStringBuffer prefix = new FastStringBuffer(); + for (; i < jars.length; i++) { + prefix.append("jar:"); + if (i == 0) { + sb.append("file:"); + } + if (jars[i] instanceof Pathname) { + sb.append(((Pathname) jars[i]).getNamestring()); + } + sb.append("!/"); + } + sb = prefix.append(sb); + } else if (device instanceof AbstractString + && device.getStringValue().startsWith("jar:")) { + sb.append(device.getStringValue()); } else if (device instanceof AbstractString) { sb.append(device.getStringValue()); if (this instanceof LogicalPathname - || host == NIL) - sb.append(':'); // non-UNC paths - } else if (device instanceof Pathname) { - sb.append(((Pathname)device).getNamestring()); - sb.append("!"); - } else + || host == NIL) { + sb.append(':'); // non-UNC paths + } + } else { Debug.assertTrue(false); + } sb.append(getDirectoryNamestring()); if (name instanceof AbstractString) { String n = name.getStringValue(); @@ -347,8 +530,9 @@ return null; } sb.append(n); - } else if (name == Keyword.WILD) + } else if (name == Keyword.WILD) { sb.append('*'); + } if (type != NIL) { sb.append('.'); if (type instanceof AbstractString) { @@ -358,19 +542,21 @@ return null; } sb.append(t); - } else if (type == Keyword.WILD) + } else if (type == Keyword.WILD) { sb.append('*'); - else + } else { Debug.assertTrue(false); + } } if (this instanceof LogicalPathname) { if (version.integerp()) { sb.append('.'); int base = Fixnum.getValue(Symbol.PRINT_BASE.symbolValue()); - if (version instanceof Fixnum) - sb.append(Integer.toString(((Fixnum)version).value, base).toUpperCase()); - else if (version instanceof Bignum) - sb.append(((Bignum)version).value.toString(base).toUpperCase()); + if (version instanceof Fixnum) { + sb.append(Integer.toString(((Fixnum) version).value, base).toUpperCase()); + } else if (version instanceof Bignum) { + sb.append(((Bignum) version).value.toString(base).toUpperCase()); + } } else if (version == Keyword.WILD) { sb.append(".*"); } else if (version == Keyword.NEWEST) { @@ -380,8 +566,7 @@ return namestring = sb.toString(); } - protected String getDirectoryNamestring() - { + protected String getDirectoryNamestring() { validateDirectory(true); FastStringBuffer sb = new FastStringBuffer(); // "If a pathname is converted to a namestring, the symbols NIL and @@ -390,10 +575,11 @@ // the namestring." 19.2.2.2.3.1 if (directory != NIL) { final char separatorChar; - if (device instanceof Pathname) + if (device instanceof Cons) { separatorChar = '/'; // Jar file. - else + } else { separatorChar = File.separatorChar; + } LispObject temp = directory; LispObject part = temp.car(); temp = temp.cdr(); @@ -407,23 +593,24 @@ } // else: Nothing to do. } else { - error(new FileError("Unsupported directory component " + - part.writeToString() + ".", - this)); + error(new FileError("Unsupported directory component " + + part.writeToString() + ".", + this)); } while (temp != NIL) { part = temp.car(); - if (part instanceof AbstractString) + if (part instanceof AbstractString) { sb.append(part.getStringValue()); - else if (part == Keyword.WILD) + } else if (part == Keyword.WILD) { sb.append('*'); - else if (part == Keyword.WILD_INFERIORS) + } else if (part == Keyword.WILD_INFERIORS) { sb.append("**"); - else if (part == Keyword.UP) + } else if (part == Keyword.UP) { sb.append(".."); - else + } else { error(new FileError("Unsupported directory component " + part.writeToString() + ".", - this)); + this)); + } sb.append(separatorChar); temp = temp.cdr(); } @@ -431,39 +618,71 @@ return sb.toString(); } + /** @return The representation of this pathname suitable for referencing an entry in a Zip/JAR file */ + protected String asEntryPath() { + Pathname p = new Pathname(); + p.directory = directory; + p.name = name; + p.type = type; + String path = p.getNamestring(); + if (Utilities.isPlatformWindows) { + StringBuilder result = new StringBuilder(); + for (int i = 0; i < path.length(); i++) { + char c = path.charAt(i); + if (c == '\\') { + result.append('/'); + } else { + result.append(c); + } + } + return result.toString(); + } + return path; + } + @Override - public boolean equal(LispObject obj) - { - if (this == obj) + public boolean equal(LispObject obj) { + if (this == obj) { return true; + } if (obj instanceof Pathname) { Pathname p = (Pathname) obj; if (Utilities.isPlatformWindows) { - if (!host.equalp(p.host)) + if (!host.equalp(p.host)) { return false; - if (!device.equalp(p.device)) + } + if (!device.equalp(p.device)) { return false; - if (!directory.equalp(p.directory)) + } + if (!directory.equalp(p.directory)) { return false; - if (!name.equalp(p.name)) + } + if (!name.equalp(p.name)) { return false; - if (!type.equalp(p.type)) + } + if (!type.equalp(p.type)) { return false; + } // Ignore version component. //if (!version.equalp(p.version)) // return false; } else { // Unix. - if (!host.equal(p.host)) + if (!host.equal(p.host)) { return false; - if (!device.equal(p.device)) + } + if (!device.equal(p.device)) { return false; - if (!directory.equal(p.directory)) + } + if (!directory.equal(p.directory)) { return false; - if (!name.equal(p.name)) + } + if (!name.equal(p.name)) { return false; - if (!type.equal(p.type)) + } + if (!type.equal(p.type)) { return false; + } // Ignore version component. //if (!version.equal(p.version)) // return false; @@ -474,24 +693,21 @@ } @Override - public boolean equalp(LispObject obj) - { + public boolean equalp(LispObject obj) { return equal(obj); } @Override - public int sxhash() - { - return ((host.sxhash() ^ - device.sxhash() ^ - directory.sxhash() ^ - name.sxhash() ^ - type.sxhash()) & 0x7fffffff); + public int sxhash() { + return ((host.sxhash() + ^ device.sxhash() + ^ directory.sxhash() + ^ name.sxhash() + ^ type.sxhash()) & 0x7fffffff); } @Override - public String writeToString() - { + public String writeToString() { final LispThread thread = LispThread.currentThread(); boolean printReadably = (Symbol.PRINT_READABLY.symbolValue(thread) != NIL); boolean printEscape = (Symbol.PRINT_ESCAPE.symbolValue(thread) != NIL); @@ -507,47 +723,52 @@ useNamestring = false; } else if (name instanceof AbstractString) { String n = name.getStringValue(); - if (n.equals(".") || n.equals("..")) + if (n.equals(".") || n.equals("..")) { useNamestring = false; - else if (n.indexOf(File.separatorChar) >= 0) + } else if (n.indexOf(File.separatorChar) >= 0) { useNamestring = false; + } } } - } else - useNamestring = false; + } else { + useNamestring = false; + } FastStringBuffer sb = new FastStringBuffer(); if (useNamestring) { - if (printReadably || printEscape) + if (printReadably || printEscape) { sb.append("#P\""); + } final int limit = s.length(); for (int i = 0; i < limit; i++) { char c = s.charAt(i); if (printReadably || printEscape) { - if (c == '\"' || c == '\\') + if (c == '\"' || c == '\\') { sb.append('\\'); + } } sb.append(c); } - if (printReadably || printEscape) + if (printReadably || printEscape) { sb.append('"'); + } } else { sb.append("#P("); if (host != NIL) { sb.append(":HOST "); sb.append(host.writeToString()); sb.append(' '); - } - if (device != NIL) { - sb.append(":DEVICE "); - sb.append(device.writeToString()); - sb.append(' '); + } + if (device != NIL) { + sb.append(":DEVICE "); + sb.append(device.writeToString()); + sb.append(' '); } if (directory != NIL) { sb.append(":DIRECTORY "); sb.append(directory.writeToString()); sb.append(" "); } - if (name != NIL) { + if (name != NIL) { sb.append(":NAME "); sb.append(name.writeToString()); sb.append(' '); @@ -562,31 +783,26 @@ sb.append(version.writeToString()); sb.append(' '); } - if (sb.charAt(sb.length() - 1) == ' ') + if (sb.charAt(sb.length() - 1) == ' ') { sb.setLength(sb.length() - 1); + } sb.append(')'); - } - return sb.toString(); + } + return sb.toString(); } - // 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); - + new EqualHashTable(64, NIL, NIL); private static final Symbol _LOGICAL_PATHNAME_TRANSLATIONS_ = - exportSpecial("*LOGICAL-PATHNAME-TRANSLATIONS*", PACKAGE_SYS, - LOGICAL_PATHNAME_TRANSLATIONS); - - public static Pathname parseNamestring(String s) + exportSpecial("*LOGICAL-PATHNAME-TRANSLATIONS*", PACKAGE_SYS, + LOGICAL_PATHNAME_TRANSLATIONS); - { + public static Pathname parseNamestring(String s) { return new Pathname(s); } - public static Pathname parseNamestring(AbstractString namestring) - - { + public static Pathname parseNamestring(AbstractString namestring) { // Check for a logical pathname host. String s = namestring.getStringValue(); String h = getHostString(s); @@ -598,17 +814,15 @@ } public static Pathname parseNamestring(AbstractString namestring, - AbstractString host) - - { + AbstractString host) { // Look for a logical pathname host in the namestring. String s = namestring.getStringValue(); String h = getHostString(s); if (h != null) { if (!h.equals(host.getStringValue())) { - error(new LispError("Host in " + s + - " does not match requested host " + - host.getStringValue())); + error(new LispError("Host in " + s + + " does not match requested host " + + host.getStringValue())); // Not reached. return null; } @@ -625,149 +839,142 @@ } // "one or more uppercase letters, digits, and hyphens" - protected static String getHostString(String s) - { + protected static String getHostString(String s) { int colon = s.indexOf(':'); - if (colon >= 0) + if (colon >= 0) { return s.substring(0, colon).toUpperCase(); - else + } else { return null; + } } - private static final void checkCaseArgument(LispObject arg) - - { - if (arg != Keyword.COMMON && arg != Keyword.LOCAL) + private static final void checkCaseArgument(LispObject arg) { + if (arg != Keyword.COMMON && arg != Keyword.LOCAL) { type_error(arg, list(Symbol.MEMBER, Keyword.COMMON, - Keyword.LOCAL)); + Keyword.LOCAL)); + } } - // ### %pathname-host - private static final Primitive _PATHNAME_HOST = - new Primitive("%pathname-host", PACKAGE_SYS, false) - { + private static final Primitive _PATHNAME_HOST = new _pathname_host(); + private static class _pathname_host extends Primitive { + _pathname_host() { + super("%pathname-host", PACKAGE_SYS, false); + } @Override - public LispObject execute(LispObject first, LispObject second) - - { + public LispObject execute(LispObject first, LispObject second) { checkCaseArgument(second); return coerceToPathname(first).host; } - }; - + } // ### %pathname-device - private static final Primitive _PATHNAME_DEVICE = - new Primitive("%pathname-device", PACKAGE_SYS, false) - { + private static final Primitive _PATHNAME_DEVICE = new _pathname_device(); + private static class _pathname_device extends Primitive { + _pathname_device() { + super("%pathname-device", PACKAGE_SYS, false); + } @Override - public LispObject execute(LispObject first, LispObject second) - - { + public LispObject execute(LispObject first, LispObject second) { checkCaseArgument(second); return coerceToPathname(first).device; } - }; - + } // ### %pathname-directory - private static final Primitive _PATHNAME_DIRECTORY = - new Primitive("%pathname-directory", PACKAGE_SYS, false) - { + private static final Primitive _PATHNAME_DIRECTORY = new _pathname_directory(); + private static class _pathname_directory extends Primitive { + _pathname_directory() { + super("%pathname-directory", PACKAGE_SYS, false); + } @Override - public LispObject execute(LispObject first, LispObject second) - - { + public LispObject execute(LispObject first, LispObject second) { checkCaseArgument(second); return coerceToPathname(first).directory; } - }; - + } // ### %pathname-name - private static final Primitive _PATHNAME_NAME = - new Primitive("%pathname-name", PACKAGE_SYS, false) - { + private static final Primitive _PATHNAME_NAME = new _pathname_name(); + private static class _pathname_name extends Primitive { + _pathname_name() { + super ("%pathname-name", PACKAGE_SYS, false); + } @Override - public LispObject execute(LispObject first, LispObject second) - - { + public LispObject execute(LispObject first, LispObject second) { checkCaseArgument(second); return coerceToPathname(first).name; } - }; - + } // ### %pathname-type - private static final Primitive _PATHNAME_TYPE = - new Primitive("%pathname-type", PACKAGE_SYS, false) - { + private static final Primitive _PATHNAME_TYPE = new _pathname_type(); + private static class _pathname_type extends Primitive { + _pathname_type() { + super("%pathname-type", PACKAGE_SYS, false); + } @Override - public LispObject execute(LispObject first, LispObject second) - - { + public LispObject execute(LispObject first, LispObject second) { checkCaseArgument(second); return coerceToPathname(first).type; } - }; - + } // ### pathname-version - private static final Primitive PATHNAME_VERSION = - new Primitive("pathname-version", "pathname") - { + private static final Primitive PATHNAME_VERSION = new pathname_version(); + private static class pathname_version extends Primitive { + pathname_version() { + super("pathname-version", "pathname"); + } @Override - public LispObject execute(LispObject arg) - { + public LispObject execute(LispObject arg) { return coerceToPathname(arg).version; } - }; - + } // ### namestring // namestring pathname => namestring - private static final Primitive NAMESTRING = - new Primitive("namestring", "pathname") - { + private static final Primitive NAMESTRING = new namestring(); + private static class namestring extends Primitive { + namestring() { + super("namestring", "pathname"); + } @Override - public LispObject execute(LispObject arg) - { + public LispObject execute(LispObject arg) { Pathname pathname = coerceToPathname(arg); String namestring = pathname.getNamestring(); - if (namestring == null) - error(new SimpleError("Pathname has no namestring: " + - pathname.writeToString())); + if (namestring == null) { + error(new SimpleError("Pathname has no namestring: " + + pathname.writeToString())); + } return new SimpleString(namestring); } - }; - + } // ### directory-namestring // directory-namestring pathname => namestring - private static final Primitive DIRECTORY_NAMESTRING = - new Primitive("directory-namestring", "pathname") - { + private static final Primitive DIRECTORY_NAMESTRING = new directory_namestring(); + private static class directory_namestring extends Primitive { + directory_namestring() { + super("directory-namestring", "pathname"); + } @Override - public LispObject execute(LispObject arg) - { + public LispObject execute(LispObject arg) { return new SimpleString(coerceToPathname(arg).getDirectoryNamestring()); } - }; - + } // ### pathname pathspec => pathname - private static final Primitive PATHNAME = - new Primitive("pathname", "pathspec") - { + private static final Primitive PATHNAME = new pathname(); + private static class pathname extends Primitive { + pathname() { + super("pathname", "pathspec"); + } @Override - public LispObject execute(LispObject arg) - { + public LispObject execute(LispObject arg) { return coerceToPathname(arg); } - }; - + } // ### %parse-namestring string host default-pathname => pathname, position - private static final Primitive _PARSE_NAMESTRING = - new Primitive("%parse-namestring", PACKAGE_SYS, false, - "namestring host default-pathname") - { + private static final Primitive _PARSE_NAMESTRING = new _parse_namestring(); + private static class _parse_namestring extends Primitive { + _parse_namestring() { + super("%parse-namestring", PACKAGE_SYS, false, + "namestring host default-pathname"); + } @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - - { + public LispObject execute(LispObject first, LispObject second, LispObject third) { final LispThread thread = LispThread.currentThread(); final AbstractString namestring = checkString(first); // The HOST parameter must be a string or NIL. @@ -778,44 +985,53 @@ // pathname namestring on the host that is the host component // of DEFAULT-PATHNAME." third = coerceToPathname(third); - if (third instanceof LogicalPathname) - second = ((LogicalPathname)third).host; - else + if (third instanceof LogicalPathname) { + second = ((LogicalPathname) third).host; + } else { return thread.setValues(parseNamestring(namestring), namestring.LENGTH()); + } } Debug.assertTrue(second != NIL); final AbstractString host = checkString(second); return thread.setValues(parseNamestring(namestring, host), namestring.LENGTH()); } - }; - + } // ### make-pathname - private static final Primitive MAKE_PATHNAME = - new Primitive("make-pathname", - "&key host device directory name type version defaults case") - { + private static final Primitive MAKE_PATHNAME = new make_pathname(); + private static class make_pathname extends Primitive { + make_pathname() { + super("make-pathname", + "&key host device directory name type version defaults case"); + } @Override - public LispObject execute(LispObject[] args) - - { + public LispObject execute(LispObject[] args) { return _makePathname(args); } - }; + } // Used by the #p reader. - public static final Pathname makePathname(LispObject args) - - { + public static final Pathname makePathname(LispObject args) { return _makePathname(args.copyToArray()); } - private static final Pathname _makePathname(LispObject[] args) + public static final Pathname makePathname(File file) { + String namestring = null; + try { + namestring = file.getCanonicalPath(); + } catch (IOException e) { + Debug.trace("Failed to make a Pathname from " + + "." + file + "'"); + return null; + } + return new Pathname(namestring); + } - { - if (args.length % 2 != 0) + private static final Pathname _makePathname(LispObject[] args) { + if (args.length % 2 != 0) { error(new ProgramError("Odd number of keyword arguments.")); + } LispObject host = NIL; LispObject device = NIL; LispObject directory = NIL; @@ -828,19 +1044,20 @@ boolean typeSupplied = false; for (int i = 0; i < args.length; i += 2) { LispObject key = args[i]; - LispObject value = args[i+1]; + LispObject value = args[i + 1]; if (key == Keyword.HOST) { host = value; } else if (key == Keyword.DEVICE) { device = value; deviceSupplied = true; } else if (key == Keyword.DIRECTORY) { - if (value instanceof AbstractString) + if (value instanceof AbstractString) { directory = list(Keyword.ABSOLUTE, value); - else if (value == Keyword.WILD) + } else if (value == Keyword.WILD) { directory = list(Keyword.ABSOLUTE, Keyword.WILD); - else + } else { directory = value; + } } else if (key == Keyword.NAME) { name = value; nameSupplied = true; @@ -852,25 +1069,30 @@ } else if (key == Keyword.DEFAULTS) { defaults = coerceToPathname(value); } else if (key == Keyword.CASE) { - // Ignored. + // Ignored. } } if (defaults != null) { - if (host == NIL) + if (host == NIL) { host = defaults.host; + } directory = mergeDirectories(directory, defaults.directory); - if (!deviceSupplied) + if (!deviceSupplied) { device = defaults.device; - if (!nameSupplied) + } + if (!nameSupplied) { name = defaults.name; - if (!typeSupplied) + } + if (!typeSupplied) { type = defaults.type; + } } final Pathname p; final boolean logical; if (host != NIL) { - if (host instanceof AbstractString) - host = LogicalPathname.canonicalizeStringComponent((AbstractString)host); + if (host instanceof AbstractString) { + host = LogicalPathname.canonicalizeStringComponent((AbstractString) host); + } if (LOGICAL_PATHNAME_TRANSLATIONS.get(host) == null) { // Not a defined logical pathname host. error(new LispError(host.writeToString() + " is not defined as a logical pathname host.")); @@ -886,10 +1108,12 @@ if (device != NIL) { if (logical) { // "The device component of a logical pathname is always :UNSPECIFIC." - if (device != Keyword.UNSPECIFIC) + if (device != Keyword.UNSPECIFIC) { error(new LispError("The device component of a logical pathname must be :UNSPECIFIC.")); - } else + } + } else { p.device = device; + } } if (directory != NIL) { if (logical) { @@ -897,48 +1121,51 @@ LispObject d = NIL; while (directory != NIL) { LispObject component = directory.car(); - if (component instanceof AbstractString) - d = d.push(LogicalPathname.canonicalizeStringComponent((AbstractString)component)); - else + if (component instanceof AbstractString) { + d = d.push(LogicalPathname.canonicalizeStringComponent((AbstractString) component)); + } else { d = d.push(component); + } directory = directory.cdr(); } p.directory = d.nreverse(); - } else if (directory == Keyword.WILD || directory == Keyword.WILD_INFERIORS) + } else if (directory == Keyword.WILD || directory == Keyword.WILD_INFERIORS) { p.directory = directory; - else + } else { error(new LispError("Invalid directory component for logical pathname: " + directory.writeToString())); - } else + } + } else { p.directory = directory; + } } if (name != NIL) { - if (logical && name instanceof AbstractString) - p.name = LogicalPathname.canonicalizeStringComponent((AbstractString)name); - else if (name instanceof AbstractString) - p.name = validateStringComponent((AbstractString)name); - else + if (logical && name instanceof AbstractString) { + p.name = LogicalPathname.canonicalizeStringComponent((AbstractString) name); + } else if (name instanceof AbstractString) { + p.name = validateStringComponent((AbstractString) name); + } else { p.name = name; + } } if (type != NIL) { - if (logical && type instanceof AbstractString) - p.type = LogicalPathname.canonicalizeStringComponent((AbstractString)type); - else + if (logical && type instanceof AbstractString) { + p.type = LogicalPathname.canonicalizeStringComponent((AbstractString) type); + } else { p.type = type; + } } p.version = version; return p; } - private static final AbstractString validateStringComponent(AbstractString s) - - { + private static final AbstractString validateStringComponent(AbstractString s) { final int limit = s.length(); for (int i = 0; i < limit; i++) { char c = s.charAt(i); if (c == '/' || c == '\\' && Utilities.isPlatformWindows) { - error(new LispError("Invalid character #\\" + c + - " in pathname component \"" + s + - '"')); + error(new LispError("Invalid character #\\" + c + + " in pathname component \"" + s + + '"')); // Not reached. return null; } @@ -946,9 +1173,7 @@ return s; } - private final boolean validateDirectory(boolean signalError) - - { + private final boolean validateDirectory(boolean signalError) { LispObject temp = directory; while (temp != NIL) { LispObject first = temp.car(); @@ -970,259 +1195,348 @@ } return true; } - // ### pathnamep - private static final Primitive PATHNAMEP = - new Primitive("pathnamep", "object") - { + private static final Primitive PATHNAMEP = new pathnamep(); + private static class pathnamep extends Primitive { + pathnamep() { + super("pathnamep", "object"); + } @Override - public LispObject execute(LispObject arg) - { + public LispObject execute(LispObject arg) { return arg instanceof Pathname ? T : NIL; } - }; - + } // ### logical-pathname-p - private static final Primitive LOGICAL_PATHNAME_P = - new Primitive("logical-pathname-p", PACKAGE_SYS, true, "object") - { + private static final Primitive LOGICAL_PATHNAME_P = new logical_pathname_p(); + private static class logical_pathname_p extends Primitive { + logical_pathname_p() { + super("logical-pathname-p", PACKAGE_SYS, true, "object"); + } @Override - public LispObject execute(LispObject arg) - { + public LispObject execute(LispObject arg) { return arg instanceof LogicalPathname ? T : NIL; } - }; - + } // ### user-homedir-pathname &optional host => pathname - private static final Primitive USER_HOMEDIR_PATHNAME = - new Primitive("user-homedir-pathname", "&optional host") - { + private static final Primitive USER_HOMEDIR_PATHNAME = new user_homedir_pathname(); + private static class user_homedir_pathname extends Primitive { + user_homedir_pathname() { + super("user-homedir-pathname", "&optional host"); + } @Override - public LispObject execute(LispObject[] args) - { + public LispObject execute(LispObject[] args) { switch (args.length) { - case 0: { - String s = System.getProperty("user.home"); - if (!s.endsWith(File.separator)) - s = s.concat(File.separator); - return new Pathname(s); - } - case 1: - return NIL; - default: - return error(new WrongNumberOfArgumentsException(this)); - } - } - }; - - // ### list-directory - private static final Primitive LIST_DIRECTORY = - new Primitive("list-directory", PACKAGE_SYS, true) - { + case 0: { + String s = System.getProperty("user.home"); + if (!s.endsWith(File.separator)) { + s = s.concat(File.separator); + } + return new Pathname(s); + } + case 1: + return NIL; // ??? huh? -- ME 20100206 + default: + return error(new WrongNumberOfArgumentsException(this)); + } + } + } + // ### list-directory directory + private static final Primitive LIST_DIRECTORY = new list_directory(); + private static class list_directory extends Primitive { + list_directory() { + super("list-directory", PACKAGE_SYS, true, "directory"); + } @Override - public LispObject execute(LispObject arg) - { + public LispObject execute(LispObject arg) { Pathname pathname = coerceToPathname(arg); - if (pathname instanceof LogicalPathname) - pathname = LogicalPathname.translateLogicalPathname((LogicalPathname)pathname); + if (pathname instanceof LogicalPathname) { + pathname = LogicalPathname.translateLogicalPathname((LogicalPathname) pathname); + } + if (pathname.isJar()) { + return error(new FileError("Unimplemented directory listing of JAR files.", pathname)); + } LispObject result = NIL; String s = pathname.getNamestring(); if (s != null) { File f = new File(s); if (f.isDirectory()) { try { - File[] files = f.listFiles(); + File[] files = f.listFiles(); for (int i = files.length; i-- > 0;) { File file = files[i]; Pathname p; - if (file.isDirectory()) + if (file.isDirectory()) { p = Utilities.getDirectoryPathname(file); - else + } else { p = new Pathname(file.getCanonicalPath()); + } result = new Cons(p, result); } - } - catch (IOException e) { + } catch (IOException e) { return error(new FileError("Unable to list directory " + pathname.writeToString() + ".", pathname)); - } - catch (SecurityException e) { - } - catch (NullPointerException e) { + } catch (SecurityException e) { + Debug.trace(e); + } catch (NullPointerException e) { + Debug.trace(e); } } } return result; } - }; + } - public boolean isWild() - { - if (host == Keyword.WILD || host == Keyword.WILD_INFERIORS) + public boolean isAbsolute() { + if (!directory.equals(NIL) || !(directory == null)) { + if (directory instanceof Cons) { + if (((Cons)directory).car().equals(Keyword.ABSOLUTE)) { + return true; + } + } + } + return false; + } + + // ### PATHNAME-JAR-P + private static final Primitive PATHNAME_JAR_P = new pathname_jar_p(); + private static class pathname_jar_p extends Primitive { + pathname_jar_p() { + super("pathname-jar-p", PACKAGE_SYS, true, "pathname", + "Predicate for whether PATHNAME references a JAR."); + } + @Override + public LispObject execute(LispObject arg) { + Pathname p = coerceToPathname(arg); + return p.isJar() ? T : NIL; + } + } + + public boolean isJar() { + if (device instanceof Cons) { + return true; + } + return false; + } + + public boolean isWild() { + if (host == Keyword.WILD || host == Keyword.WILD_INFERIORS) { return true; - if (device == Keyword.WILD || device == Keyword.WILD_INFERIORS) + } + if (device == Keyword.WILD || device == Keyword.WILD_INFERIORS) { return true; + } if (directory instanceof Cons) { - if (memq(Keyword.WILD, directory)) + if (memq(Keyword.WILD, directory)) { return true; - if (memq(Keyword.WILD_INFERIORS, directory)) + } + if (memq(Keyword.WILD_INFERIORS, directory)) { return true; + } } - if (name == Keyword.WILD || name == Keyword.WILD_INFERIORS) + if (name == Keyword.WILD || name == Keyword.WILD_INFERIORS) { return true; - if (type == Keyword.WILD || type == Keyword.WILD_INFERIORS) + } + if (type == Keyword.WILD || type == Keyword.WILD_INFERIORS) { return true; - if (version == Keyword.WILD || version == Keyword.WILD_INFERIORS) + } + if (version == Keyword.WILD || version == Keyword.WILD_INFERIORS) { return true; + } return false; } - // ### %wild-pathname-p private static final Primitive _WILD_PATHNAME_P = - new Primitive("%wild-pathname-p", PACKAGE_SYS, true) - { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - Pathname pathname = coerceToPathname(first); - if (second == NIL) - return pathname.isWild() ? T : NIL; - if (second == Keyword.DIRECTORY) { - if (pathname.directory instanceof Cons) { - if (memq(Keyword.WILD, pathname.directory)) - return T; - if (memq(Keyword.WILD_INFERIORS, pathname.directory)) - return T; - } - return NIL; - } - LispObject value; - if (second == Keyword.HOST) - value = pathname.host; - else if (second == Keyword.DEVICE) - value = pathname.device; - else if (second == Keyword.NAME) - value = pathname.name; - else if (second == Keyword.TYPE) - value = pathname.type; - else if (second == Keyword.VERSION) - value = pathname.version; - else - return error(new ProgramError("Unrecognized keyword " + - second.writeToString() + ".")); - if (value == Keyword.WILD || value == Keyword.WILD_INFERIORS) - return T; - else - return NIL; - } - }; + new Primitive("%wild-pathname-p", PACKAGE_SYS, true) { + @Override + public LispObject execute(LispObject first, LispObject second) { + Pathname pathname = coerceToPathname(first); + if (second == NIL) { + return pathname.isWild() ? T : NIL; + } + if (second == Keyword.DIRECTORY) { + if (pathname.directory instanceof Cons) { + if (memq(Keyword.WILD, pathname.directory)) { + return T; + } + if (memq(Keyword.WILD_INFERIORS, pathname.directory)) { + return T; + } + } + return NIL; + } + LispObject value; + if (second == Keyword.HOST) { + value = pathname.host; + } else if (second == Keyword.DEVICE) { + value = pathname.device; + } else if (second == Keyword.NAME) { + value = pathname.name; + } else if (second == Keyword.TYPE) { + value = pathname.type; + } else if (second == Keyword.VERSION) { + value = pathname.version; + } else { + return error(new ProgramError("Unrecognized keyword " + + second.writeToString() + ".")); + } + if (value == Keyword.WILD || value == Keyword.WILD_INFERIORS) { + return T; + } else { + return NIL; + } + } + }; // ### merge-pathnames private static final Primitive MERGE_PATHNAMES = - new Primitive("merge-pathnames", - "pathname &optional default-pathname default-version") - { - @Override - public LispObject execute(LispObject arg) - { - Pathname pathname = coerceToPathname(arg); - Pathname defaultPathname = + new Primitive("merge-pathnames", + "pathname &optional default-pathname default-version") { + + @Override + public LispObject execute(LispObject arg) { + Pathname pathname = coerceToPathname(arg); + Pathname defaultPathname = coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue()); - LispObject defaultVersion = Keyword.NEWEST; - return mergePathnames(pathname, defaultPathname, defaultVersion); + LispObject defaultVersion = Keyword.NEWEST; + return mergePathnames(pathname, defaultPathname, defaultVersion); + } + + @Override + public LispObject execute(LispObject first, LispObject second) { + Pathname pathname = coerceToPathname(first); + Pathname defaultPathname = + coerceToPathname(second); + LispObject defaultVersion = Keyword.NEWEST; + return mergePathnames(pathname, defaultPathname, defaultVersion); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) { + Pathname pathname = coerceToPathname(first); + Pathname defaultPathname = + coerceToPathname(second); + LispObject defaultVersion = third; + return mergePathnames(pathname, defaultPathname, defaultVersion); + } + }; + + public static final Pathname mergePathnames(Pathname pathname, Pathname defaultPathname) { + return mergePathnames(pathname, defaultPathname, Keyword.NEWEST); + } + + public static final Pathname mergePathnames(final Pathname pathname, + final Pathname defaultPathname, + final LispObject defaultVersion) + { + Pathname result; + Pathname p = new Pathname(pathname); + Pathname d; + + if (pathname instanceof LogicalPathname) { + result = new LogicalPathname(); + d = new Pathname(defaultPathname); + } else { + result = new Pathname(); + if (defaultPathname instanceof LogicalPathname) { + d = LogicalPathname.translateLogicalPathname((LogicalPathname) defaultPathname); + } else { + d = new Pathname(defaultPathname); + } + } + if (pathname.host != NIL) { + result.host = p.host; + } else { + result.host = d.host; } - @Override - public LispObject execute(LispObject first, LispObject second) - { - Pathname pathname = coerceToPathname(first); - Pathname defaultPathname = - coerceToPathname(second); - LispObject defaultVersion = Keyword.NEWEST; - return mergePathnames(pathname, defaultPathname, defaultVersion); + if (pathname.device != NIL) { // XXX if device represent JARs we want to merge + result.device = p.device; + } else { + result.device = d.device; } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - { - Pathname pathname = coerceToPathname(first); - Pathname defaultPathname = - coerceToPathname(second); - LispObject defaultVersion = third; - return mergePathnames(pathname, defaultPathname, defaultVersion); + if (pathname.isJar()) { + Cons jars = (Cons)result.device; + LispObject jar = jars.car; + if (jar instanceof Pathname) { + Pathname defaults = new Pathname(d); + if (defaults.isJar()) { + defaults.device = NIL; + } + Pathname o = mergePathnames((Pathname)jar, defaults); + if (o.directory instanceof Cons + && ((Cons)o.directory).length() == 1) { // i.e. (:ABSOLUTE) or (:RELATIVE) + o.directory = NIL; + } + ((Cons)result.device).car = o; + } + } else { + result.directory = mergeDirectories(p.directory, d.directory); } - }; - public static final Pathname mergePathnames(Pathname pathname, - Pathname defaultPathname, - LispObject defaultVersion) + // A JAR always has relative directories + if (result.isJar() + && result.directory instanceof Cons + && result.directory.car().equals(Keyword.ABSOLUTE)) { + if (result.directory.cdr().equals(NIL)) { + result.directory = NIL; + } else { + ((Cons)result.directory).car = Keyword.RELATIVE; + } + } - { - Pathname p; - if (pathname instanceof LogicalPathname) - p = new LogicalPathname(); - else { - p = new Pathname(); - if (defaultPathname instanceof LogicalPathname) - defaultPathname = LogicalPathname.translateLogicalPathname((LogicalPathname)defaultPathname); + if (pathname.name != NIL) { + result.name = p.name; + } else { + result.name = d.name; } - if (pathname.host != NIL) - p.host = pathname.host; - else - p.host = defaultPathname.host; - if (pathname.device != NIL) - p.device = pathname.device; - else - p.device = defaultPathname.device; - p.directory = - mergeDirectories(pathname.directory, defaultPathname.directory); - if (pathname.name != NIL) - p.name = pathname.name; - else - p.name = defaultPathname.name; - if (pathname.type != NIL) - p.type = pathname.type; - else - p.type = defaultPathname.type; - if (pathname.version != NIL) - p.version = pathname.version; - else if (pathname.name instanceof AbstractString) - p.version = defaultVersion; - else if (defaultPathname.version != NIL) - p.version = defaultPathname.version; - else - p.version = defaultVersion; - if (p instanceof LogicalPathname) { + if (pathname.type != NIL) { + result.type = p.type; + } else { + result.type = d.type; + } + if (pathname.version != NIL) { + result.version = pathname.version; + } else if (pathname.name instanceof AbstractString) { + result.version = defaultVersion; + } else if (defaultPathname.version != NIL) { + result.version = defaultPathname.version; + } else { + result.version = defaultVersion; + } + if (pathname instanceof LogicalPathname) { // When we're returning a logical - p.device = Keyword.UNSPECIFIC; - if (p.directory.listp()) { - LispObject original = p.directory; + result.device = Keyword.UNSPECIFIC; + if (result.directory.listp()) { + LispObject original = result.directory; LispObject canonical = NIL; while (original != NIL) { LispObject component = original.car(); - if (component instanceof AbstractString) - component = LogicalPathname.canonicalizeStringComponent((AbstractString)component); + if (component instanceof AbstractString) { + component = LogicalPathname.canonicalizeStringComponent((AbstractString) component); + } canonical = canonical.push(component); original = original.cdr(); } - p.directory = canonical.nreverse(); + result.directory = canonical.nreverse(); + } + if (result.name instanceof AbstractString) { + result.name = LogicalPathname.canonicalizeStringComponent((AbstractString) result.name); + } + if (result.type instanceof AbstractString) { + result.type = LogicalPathname.canonicalizeStringComponent((AbstractString) result.type); } - if (p.name instanceof AbstractString) - p.name = LogicalPathname.canonicalizeStringComponent((AbstractString)p.name); - if (p.type instanceof AbstractString) - p.type = LogicalPathname.canonicalizeStringComponent((AbstractString)p.type); } - return p; + result.invalidateNamestring(); + return result; } private static final LispObject mergeDirectories(LispObject dir, - LispObject defaultDir) - - { - if (dir == NIL) + LispObject defaultDir) { + if (dir == NIL) { return defaultDir; + } if (dir.car() == Keyword.RELATIVE && defaultDir != NIL) { LispObject result = NIL; while (defaultDir != NIL) { @@ -1237,154 +1551,446 @@ LispObject[] array = result.copyToArray(); for (int i = 0; i < array.length - 1; i++) { if (array[i] == Keyword.BACK) { - if (array[i+1] instanceof AbstractString || array[i+1] == Keyword.WILD) { + if (array[i + 1] instanceof AbstractString || array[i + 1] == Keyword.WILD) { array[i] = null; - array[i+1] = null; + array[i + 1] = null; } } } result = NIL; for (int i = 0; i < array.length; i++) { - if (array[i] != null) + if (array[i] != null) { result = new Cons(array[i], result); + } } return result; } return dir; } - public static final LispObject truename(LispObject arg, - boolean errorIfDoesNotExist) + public static final LispObject truename(Pathname pathname) { + return truename(pathname, false); + } + + public static final LispObject truename(LispObject arg) { + return truename(arg, false); + } + public static final LispObject truename(LispObject arg, boolean errorIfDoesNotExist) { + final Pathname pathname = coerceToPathname(arg); + return truename(pathname, errorIfDoesNotExist); + } + + /** @return The canonical TRUENAME as a Pathname if the pathname + * exists, otherwise returns NIL or possibly a subtype of + * LispError if there are logical problems with the input. + */ + public static final LispObject truename(Pathname pathname, + boolean errorIfDoesNotExist) { - Pathname pathname = coerceToPathname(arg); - if (pathname instanceof LogicalPathname) - pathname = LogicalPathname.translateLogicalPathname((LogicalPathname)pathname); - if (pathname.isWild()) + if (pathname instanceof LogicalPathname) { + pathname = LogicalPathname.translateLogicalPathname((LogicalPathname) pathname); + } + if (pathname.isWild()) { return error(new FileError("Bad place for a wild pathname.", - pathname)); - final Pathname defaultedPathname = - mergePathnames(pathname, - coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue()), - NIL); - final String namestring = defaultedPathname.getNamestring(); - if (namestring == null) - return error(new FileError("Pathname has no namestring: " + defaultedPathname.writeToString(), - defaultedPathname)); - final File file = new File(namestring); - if (file.isDirectory()) - return Utilities.getDirectoryPathname(file); - if (file.exists()) { - try { - return new Pathname(file.getCanonicalPath()); + pathname)); + } + if (!(pathname.device instanceof Cons)) { + pathname + = mergePathnames(pathname, + coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue()), + NIL); + final String namestring = pathname.getNamestring(); + if (namestring == null) { + return error(new FileError("Pathname has no namestring: " + + pathname.writeToString(), + pathname)); + } + + final File file = new File(namestring); + if (file.isDirectory()) { + return Utilities.getDirectoryPathname(file); + } + if (file.exists()) { + try { + return new Pathname(file.getCanonicalPath()); + } catch (IOException e) { + return error(new FileError(e.getMessage(), pathname)); + } } - catch (IOException e) { - return error(new LispError(e.getMessage())); + } else + jarfile: { + // Possibly canonicalize jar file directory + Cons jars = (Cons) pathname.device; + LispObject o = jars.car(); + if (o instanceof Pathname) { + LispObject truename = Pathname.truename((Pathname)o, errorIfDoesNotExist); + if (truename != null + && truename instanceof Pathname) { + jars.car = (Pathname)truename; + } else { + break jarfile; + } + } + + // Check for existence of a JAR file and/or JarEntry + // + // Cases: + // 1. JAR + // 2. JAR in JAR + // 3. JAR with Entry + // 4. JAR in JAR with Entry + JarFile jarFile = getJarFile(jars.car()); + String entryPath = pathname.asEntryPath(); + if (jarFile != null) { + if (jars.cdr() instanceof Cons) { + Pathname inner = (Pathname) jars.cdr().car(); + InputStream inputStream = Utilities.getInputStream(jarFile, inner); + if (inputStream != null) { + if (entryPath.length() == 0) { + return pathname; // Case 2 + } else { + ZipInputStream zipInputStream + = new ZipInputStream(inputStream); + ZipEntry entry = Utilities.getEntry(zipInputStream, + entryPath, + false); + if (entry != null) { + // XXX this could possibly be a directory? + return pathname; // Case 4 + } + } + } + } else { + if (entryPath.length() == 0) { + return pathname; // Case 1 + } else { + ZipEntry entry = jarFile.getEntry(entryPath); + if (entry != null) { + // ensure this isn't a directory + try { + InputStream input = jarFile.getInputStream(entry); + if (input != null) { + return pathname; // Case 3 + } + } catch (IOException e) { + break jarfile; + } + } + } + } } } + error: if (errorIfDoesNotExist) { FastStringBuffer sb = new FastStringBuffer("The file "); - sb.append(defaultedPathname.writeToString()); + sb.append(pathname.writeToString()); sb.append(" does not exist."); - return error(new FileError(sb.toString(), defaultedPathname)); + return error(new FileError(sb.toString(), pathname)); } return NIL; } + + /** Make a JarURL from a Pathname that references a file */ + private static URL makeJarURL(Pathname p) { + String jarURL = "jar:file:" + p.getNamestring() + "!/"; + URL result = null; + try { + result = new URL(jarURL); + } catch (MalformedURLException ex) { + // XXX + Debug.trace("Could not form URL from pathname " + + "'" + jarURL + "'" + + " because " + ex); + } + return result; + } + + /** Make a JarURL from a generic URL reference. */ + private static URL makeJarURL(String url) { + String jarURL = "jar:" + url + "!/"; + URL result = null; + try { + result = new URL(jarURL); + } catch (MalformedURLException ex) { + // XXX + Debug.trace("Could not form jar URL from " + + "'" + jarURL + "'" + + " because " + ex); + } + return result; + } + + private static JarFile getJarFile(LispObject device) { + URL url = null; + if (device instanceof SimpleString) { + url = makeJarURL(((SimpleString) device).getStringValue()); + } else { + url = makeJarURL((Pathname) device); + } + if (url == null) { + return null; + } + URLConnection connection; + try { + connection = url.openConnection(); + } catch (IOException ex) { + Debug.trace("Failed to open " + + "'" + url + "'"); + return null; + } + if (!(connection instanceof JarURLConnection)) { + // XXX + Debug.trace("Could not get a URLConnection from " + url); + return null; + } + JarURLConnection jarURLConnection = (JarURLConnection) connection; + + JarFile result; + try { + result = jarURLConnection.getJarFile(); + } catch (IOException ex) { + Debug.trace("Could not get a JarURLConnection from " + + "'" + jarURLConnection + "'"); + return null; + } + return result; + } + + public InputStream getInputStream() { + InputStream result = null; + if (isJar()) { + String entryPath = asEntryPath(); + // XXX We only return the bytes of an entry in a JAR + Debug.assertTrue(entryPath != null); + JarFile jarFile = Pathname.getJarFile(device.car()); + Debug.assertTrue(jarFile != null); + // Is this a JAR within a JAR? + if (device.cdr() instanceof Cons) { + Pathname inner = (Pathname) device.cdr().car(); + InputStream input = Utilities.getInputStream(jarFile, inner); + ZipInputStream zipInputStream = new ZipInputStream(input); + result = Utilities.getEntryAsInputStream(zipInputStream, entryPath); + } else { + ZipEntry entry = jarFile.getEntry(entryPath); + if (entry == null) { + Debug.trace("Failed to get InputStream for " + + "'" + getNamestring() + "'"); + + Debug.assertTrue(false); + } + try { + result = jarFile.getInputStream(entry); + } catch (IOException e) { + Debug.trace("Failed to get InputStream from " + + "'" + getNamestring() + "'" + + ": " + e); + } + } + } else { + File file = Utilities.getFile(this); + try { + result = new FileInputStream(file); + } catch (IOException e) { + Debug.trace("Failed to get InputStream for read from " + + "'" + getNamestring() + "'" + + ": " + e); + } + } + return result; + } + + // ### last-modified pathname => time-in-milliseconds + public static final Primitive LAST_MODIFIED + = new Primitive("LAST-MODIFIED", PACKAGE_EXT, true, "pathname", + "If PATHNAME exists, returns the last modified time in miliseconds since the UNIX epoch.") + { + @Override + public LispObject execute(LispObject arg) { + final Pathname p = coerceToPathname(arg); + if (p.isWild()) { + error(new FileError("Bad place for a wild pathname.", p)); + } + long time = p.getLastModified(); + return LispInteger.getInstance(time); + } + }; + + /** @return Time in milliseconds since the UNIX epoch at which the + * resource was last modified, or 0 if the time is unknown. + */ + public long getLastModified() { + if (!(device instanceof Cons)) { + File f = Utilities.getFile(this); + return f.lastModified(); + } + // JAR cases + // 0. JAR from URL + // 1. JAR + // 2. JAR in JAR + // 3. Entry in JAR + // 4. Entry in JAR in JAR + String entryPath = asEntryPath(); + Cons d = (Cons)device; + if (d.cdr().equals(NIL)) { + if (entryPath.length() == 0) { + LispObject o = d.car(); + if (o instanceof SimpleString) { + // 0. JAR from URL + URL u = makeJarURL(o.getStringValue()); + URLConnection c = null; + try { + c = u.openConnection(); + } catch(IOException e) { + Debug.trace("Failed to open Connection for URL " + + "'" + u + "'"); + return 0; + } + c.getLastModified(); + } else { + // 1. JAR + return ((Pathname)o).getLastModified(); + } + } else { + // 3. Entry in JAR + final JarEntry entry = getJarFile(device.car()).getJarEntry(entryPath); + if (entry == null) { + return 0; + } + final long time = entry.getTime(); + if (time == -1) { + return 0; + } + return time; + } + } else { + JarFile outerJar = getJarFile(d.car()); + if (entryPath.length() == 0) { + // 4. JAR in JAR + String jarPath = ((Pathname)d.cdr()).asEntryPath(); + final JarEntry entry = outerJar.getJarEntry(jarPath); + final long time = entry.getTime(); + if (time == -1) { + return 0; + } + return time; + } else { + // 5. Entry in JAR in JAR + String innerJarPath = ((Pathname)d.cdr()).asEntryPath(); + ZipEntry entry = outerJar.getEntry(entryPath); + ZipInputStream innerJarInputStream + = Utilities.getZipInputStream(outerJar, innerJarPath); + ZipEntry innerEntry = Utilities.getEntry(innerJarInputStream, + entryPath); + long time = innerEntry.getTime(); + if (time == -1) { + return 0; + } + return time; + } + } + return 0; + } + // ### mkdir private static final Primitive MKDIR = - new Primitive("mkdir", PACKAGE_SYS, false) - { - @Override - public LispObject execute(LispObject arg) - { - final Pathname pathname = coerceToPathname(arg); - if (pathname.isWild()) - error(new FileError("Bad place for a wild pathname.", pathname)); - Pathname defaultedPathname = - mergePathnames(pathname, - coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue()), - NIL); - File file = Utilities.getFile(defaultedPathname); - return file.mkdir() ? T : NIL; - } - }; + new Primitive("mkdir", PACKAGE_SYS, false) { + @Override + public LispObject execute(LispObject arg) { + final Pathname pathname = coerceToPathname(arg); + if (pathname.isWild()) { + error(new FileError("Bad place for a wild pathname.", pathname)); + } + Pathname defaultedPathname = + mergePathnames(pathname, + coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue()), + NIL); + File file = Utilities.getFile(defaultedPathname); + return file.mkdir() ? T : NIL; + } + }; // ### rename-file filespec new-name => defaulted-new-name, old-truename, new-truename public static final Primitive RENAME_FILE = - new Primitive("rename-file", "filespec new-name") - { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - final Pathname original = (Pathname) truename(first, true); - final String originalNamestring = original.getNamestring(); - Pathname newName = coerceToPathname(second); - if (newName.isWild()) - error(new FileError("Bad place for a wild pathname.", newName)); - newName = mergePathnames(newName, original, NIL); - final String newNamestring; - if (newName instanceof LogicalPathname) - newNamestring = LogicalPathname.translateLogicalPathname((LogicalPathname)newName).getNamestring(); - else - newNamestring = newName.getNamestring(); - if (originalNamestring != null && newNamestring != null) { - final File source = new File(originalNamestring); - final File destination = new File(newNamestring); - if (Utilities.isPlatformWindows) { - if (destination.isFile()) - destination.delete(); - } - if (source.renameTo(destination)) - // Success! - return LispThread.currentThread().setValues(newName, original, - truename(newName, true)); - } - return error(new FileError("Unable to rename " + - original.writeToString() + - " to " + newName.writeToString() + - ".")); - } - }; + new Primitive("rename-file", "filespec new-name") { + @Override + public LispObject execute(LispObject first, LispObject second) { + final Pathname original = (Pathname) truename(first, true); + final String originalNamestring = original.getNamestring(); + Pathname newName = coerceToPathname(second); + if (newName.isWild()) { + error(new FileError("Bad place for a wild pathname.", newName)); + } + newName = mergePathnames(newName, original, NIL); + final String newNamestring; + if (newName instanceof LogicalPathname) { + newNamestring = LogicalPathname.translateLogicalPathname((LogicalPathname) newName).getNamestring(); + } else { + newNamestring = newName.getNamestring(); + } + if (originalNamestring != null && newNamestring != null) { + final File source = new File(originalNamestring); + final File destination = new File(newNamestring); + if (Utilities.isPlatformWindows) { + if (destination.isFile()) { + destination.delete(); + } + } + if (source.renameTo(destination)) // Success! + { + return LispThread.currentThread().setValues(newName, original, + truename(newName, true)); + } + } + return error(new FileError("Unable to rename " + + original.writeToString() + + " to " + newName.writeToString() + + ".")); + } + }; // ### file-namestring pathname => namestring private static final Primitive FILE_NAMESTRING = - new Primitive("file-namestring", "pathname") - { - @Override - public LispObject execute(LispObject arg) - { - Pathname p = coerceToPathname(arg); - FastStringBuffer sb = new FastStringBuffer(); - if (p.name instanceof AbstractString) - sb.append(p.name.getStringValue()); - else if (p.name == Keyword.WILD) - sb.append('*'); - else - return NIL; - if (p.type instanceof AbstractString) { - sb.append('.'); - sb.append(p.type.getStringValue()); - } else if (p.type == Keyword.WILD) - sb.append(".*"); - return new SimpleString(sb); - } - }; + new Primitive("file-namestring", "pathname") { + @Override + public LispObject execute(LispObject arg) { + Pathname p = coerceToPathname(arg); + FastStringBuffer sb = new FastStringBuffer(); + if (p.name instanceof AbstractString) { + sb.append(p.name.getStringValue()); + } else if (p.name == Keyword.WILD) { + sb.append('*'); + } else { + return NIL; + } + if (p.type instanceof AbstractString) { + sb.append('.'); + sb.append(p.type.getStringValue()); + } else if (p.type == Keyword.WILD) { + sb.append(".*"); + } + return new SimpleString(sb); + } + }; // ### host-namestring pathname => namestring private static final Primitive HOST_NAMESTRING = - new Primitive("host-namestring", "pathname") - { - @Override - public LispObject execute(LispObject arg) - { - return coerceToPathname(arg).host; - } - }; + new Primitive("host-namestring", "pathname") { + + @Override + public LispObject execute(LispObject arg) { + return coerceToPathname(arg).host; + } + }; + + public String toString() { + return getNamestring(); + } static { LispObject obj = Symbol.DEFAULT_PATHNAME_DEFAULTS.getSymbolValue(); Symbol.DEFAULT_PATHNAME_DEFAULTS.setSymbolValue(coerceToPathname(obj)); } } + Modified: trunk/abcl/src/org/armedbear/lisp/Site.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Site.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Site.java Sat Feb 6 05:52:32 2010 @@ -42,40 +42,36 @@ public final class Site { - private static final String LISP_HOME; + private static Pathname LISP_HOME; - static { - String lispHome = System.getProperty("abcl.home"); - if (lispHome == null) { - URL url = Lisp.class.getResource("boot.lisp"); - if (url != null) { - String protocol = url.getProtocol(); - if (protocol != null && protocol.equals("file")) { - String path = url.getPath(); - try { - path = URLDecoder.decode(path, "UTF-8"); - } - catch (java.io.UnsupportedEncodingException uee) { - // can't happen: Java implementations are required to - // support UTF-8 - } - int index = path.lastIndexOf('/'); - if (index >= 0) { - lispHome = path.substring(0, index + 1); - if (Utilities.isPlatformWindows) { - if (lispHome.length() > 0 && lispHome.charAt(0) == '/') - lispHome = lispHome.substring(1); - } - } - } + private static void init() { + String s = System.getProperty("abcl.home"); + if (s != null) { + String fileSeparator = System.getProperty("file.separator"); + if (!s.endsWith(fileSeparator)) { + s += fileSeparator;; } + LISP_HOME = new Pathname(s); + return; + } + URL url = Lisp.class.getResource("boot.lisp"); + if (url != null) { + LISP_HOME = new Pathname(url); + LISP_HOME.name = NIL; + LISP_HOME.type = NIL; + LISP_HOME.invalidateNamestring(); + return; } - LISP_HOME = lispHome; + Debug.trace("Unable to determine LISP_HOME."); } - public static final String getLispHome() + + public static final Pathname getLispHome() { - return LISP_HOME; + if (LISP_HOME == null) { + init(); + } + return LISP_HOME; } // ### *lisp-home* @@ -83,8 +79,8 @@ exportSpecial("*LISP-HOME*", PACKAGE_EXT, NIL); static { - String s = Site.getLispHome(); - if (s != null) - _LISP_HOME_.setSymbolValue(new Pathname(s)); + Pathname p = Site.getLispHome(); + if (p != null) + _LISP_HOME_.setSymbolValue(p); } } Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Sat Feb 6 05:52:32 2010 @@ -394,7 +394,7 @@ { LispObject result = readPreservingWhitespace(eofError, eofValue, - recursive, thread); + recursive, thread); if (result != eofValue && !recursive) { try { if (_charReady()) { @@ -422,9 +422,9 @@ internSpecial("*SHARP-EQUAL-ALIST*", PACKAGE_SYS, NIL); public LispObject readPreservingWhitespace(boolean eofError, - LispObject eofValue, - boolean recursive, - LispThread thread) + LispObject eofValue, + boolean recursive, + LispThread thread) { if (recursive) { @@ -434,6 +434,7 @@ try { n = _readChar(); } catch (IOException e) { + Debug.trace(e); error(new StreamError(this, e)); } if (n < 0) { Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Sat Feb 6 05:52:32 2010 @@ -2909,6 +2909,8 @@ PACKAGE_EXT.addExternalSymbol("GETENV"); public static final Symbol MACROEXPAND_ALL = PACKAGE_EXT.addExternalSymbol("MACROEXPAND-ALL"); + public static final Symbol LOAD_TRUENAME_FASL = + PACKAGE_EXT.addExternalSymbol("*LOAD-TRUENAME-FASL*"); // MOP. public static final Symbol STANDARD_READER_METHOD = Modified: trunk/abcl/src/org/armedbear/lisp/Utilities.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Utilities.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Utilities.java Sat Feb 6 05:52:32 2010 @@ -40,6 +40,7 @@ import java.io.File; import java.io.IOException; import java.io.InputStream; +import java.util.jar.JarFile; import java.util.zip.ZipEntry; import java.util.zip.ZipFile; import java.util.zip.ZipInputStream; @@ -124,60 +125,133 @@ return null; } } - - public static byte[] getZippedZipEntryAsByteArray(ZipFile zipfile, - String entryName, - String subEntryName) - { - ZipEntry entry = zipfile.getEntry(entryName); - - ZipInputStream stream = null; - try { - stream = new ZipInputStream(zipfile.getInputStream(entry)); - } - catch (IOException e) { + public static ZipInputStream getZipInputStream(ZipFile zipfile, + String entryName) { + return Utilities.getZipInputStream(zipfile, entryName, false); + } + + public static ZipInputStream getZipInputStream(ZipFile zipfile, + String entryName, + boolean errorOnFailure) { + ZipEntry zipEntry = zipfile.getEntry(entryName); + ZipInputStream stream = null; + try { + stream = new ZipInputStream(zipfile.getInputStream(zipEntry)); + } catch (IOException e) { + if (errorOnFailure) { Lisp.error(new FileError("Failed to open '" + entryName + "' in zipfile '" + zipfile + "': " + e.getMessage())); } - // XXX Cache the zipEntries somehow - do { - try { - entry = stream.getNextEntry(); - } catch (IOException e){ - Lisp.error(new FileError("Failed to seek for '" + subEntryName - + "' in '" - + zipfile.getName() + ":" + entryName + ".:" - + e.getMessage())); - } - } while (!entry.getName().equals(subEntryName)); - - ByteArrayOutputStream buffer = new ByteArrayOutputStream(); + return null; + } + return stream; + } + + public static InputStream getEntryAsInputStream(ZipInputStream zipInputStream, + String entryName) + { + ZipEntry entry = getEntry(zipInputStream, entryName); + ByteArrayOutputStream bytes = readEntry(zipInputStream); + return new ByteArrayInputStream(bytes.toByteArray()); + + } + + public static ByteArrayOutputStream readEntry(ZipInputStream stream) { + ByteArrayOutputStream result = new ByteArrayOutputStream(); int count; byte buf[] = new byte[1024]; try { while ((count = stream.read(buf, 0, buf.length)) != -1) { - buffer.write(buf, 0, count); + result.write(buf, 0, count); } } catch (java.io.IOException e) { - Lisp.error(new FileError("Failed to read compressed '" - + subEntryName - + "' in '" - + zipfile.getName() + ":" + entryName + ":" - + e.getMessage())); + Debug.trace("Failed to read entry from " + + stream + + ": " + e); + return null; } - return buffer.toByteArray(); + return result; + } + + public static ZipEntry getEntry(ZipInputStream zipInputStream, String entryName) { + return Utilities.getEntry(zipInputStream, entryName, false); } - - public static InputStream getZippedZipEntryAsInputStream(ZipFile zipfile, - String entryName, - String subEntryName) + public static ZipEntry getEntry(ZipInputStream zipInputStream, + String entryName, + boolean errorOnFailure) { - return - new ByteArrayInputStream(Utilities - .getZippedZipEntryAsByteArray(zipfile, entryName, - subEntryName)); + ZipEntry entry = null; + do { + try { + entry = zipInputStream.getNextEntry(); + } catch (IOException e) { + if (errorOnFailure) { + Lisp.error(new FileError("Failed to seek for " + + "'" + entryName + "'" + + " in " + zipInputStream.toString())); + } + return null; + } + } while (entry != null && !entry.getName().equals(entryName)); + if (entry != null) { + return entry; + } + if (errorOnFailure) { + Lisp.error(new FileError("Failed to find " + + "'" + entryName + "'" + + " in " + zipInputStream.toString())); + } + return null; + } -} + + public static final boolean checkZipFile(Pathname name) { + InputStream input = name.getInputStream(); + try { + byte[] bytes = new byte[4]; + int bytesRead = input.read(bytes); + return (bytesRead == 4 + && bytes[0] == 0x50 + && bytes[1] == 0x4b + && bytes[2] == 0x03 + && bytes[3] == 0x04); + } catch (Throwable t) { // any error probably means 'no' + return false; + } finally { + if (input != null) { + try { + input.close(); + } + catch (IOException e) {} // ignore exceptions + } + } + } + static InputStream getInputStream(JarFile jarFile, Pathname inner) { + String entryPath = inner.asEntryPath(); + ZipEntry entry = jarFile.getEntry(entryPath); + if (entry == null) { + Debug.trace("Failed to find entry " + + "'" + entryPath + "'" + + " in " + + "'" + jarFile.getName() + "'"); + return null; + } + InputStream result = null; + try { + result = jarFile.getInputStream(entry); + } catch (IOException e) { + Debug.trace("Failed to open InputStream for " + + "'" + entryPath + "'" + + " in " + + "'" + jarFile.getName() + "'"); + return null; + } + return result; + } + + + +} Added: trunk/abcl/src/org/armedbear/lisp/asdf-abcl.lisp ============================================================================== --- (empty file) +++ trunk/abcl/src/org/armedbear/lisp/asdf-abcl.lisp Sat Feb 6 05:52:32 2010 @@ -0,0 +1,48 @@ +;;; asdf-abcl.lisp +;;; +;;; Copyright (C) 2010 Mark Evenson +;;; $Id: package.lisp 12418 2010-02-05 15:41:42Z mevenson $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package :asdf) +;;;; ABCL-specific extensions to ASDF, placed in a separate file from +;;;; asdf.lisp so that we can track upstream ASDF versions easier. + +;;; We don't compile if the output location would be within a JAR +;;; file, which is currently always an unwritable location in ABCL. +;;; This allows us to load ASDF definitions that are packaged in JARs. +;;; +;;; XXX How does this work with ASDF-BINARY-LOCATIONS? +(defmethod operation-done-p :around ((o compile-op) + (c cl-source-file)) + (let ((files (output-files o c))) + (if (every #'sys:pathname-jar-p files) + t + (call-next-method)))) + +(provide 'asdf-abcl) 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 Sat Feb 6 05:52:32 2010 @@ -1173,4 +1173,5 @@ (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*) (pushnew 'contrib-sysdef-search *system-definition-search-functions*)) +(require 'asdf-abcl) (provide 'asdf) Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Sat Feb 6 05:52:32 2010 @@ -121,12 +121,13 @@ (load (do-compile "concatenate.lisp")) (load (do-compile "ldb.lisp")) (load (do-compile "destructuring-bind.lisp")) + (load (do-compile "asdf.lisp")) ;; But not for these. (mapc #'do-compile '("adjoin.lisp" "and.lisp" "apropos.lisp" "arrays.lisp" - "asdf.lisp" + "asdf-abcl.lisp" "assert.lisp" "assoc.lisp" "autoloads.lisp" @@ -211,8 +212,8 @@ "or.lisp" "parse-integer.lisp" "parse-lambda-list.lisp" - "pathnames.lisp" "package.lisp" + "pathnames.lisp" "print-object.lisp" "print-unreadable-object.lisp" "proclaim.lisp" Modified: trunk/abcl/src/org/armedbear/lisp/file_write_date.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/file_write_date.java (original) +++ trunk/abcl/src/org/armedbear/lisp/file_write_date.java Sat Feb 6 05:52:32 2010 @@ -51,8 +51,7 @@ Pathname pathname = coerceToPathname(arg); if (pathname.isWild()) error(new FileError("Bad place for a wild pathname.", pathname)); - File file = Utilities.getFile(pathname); - long lastModified = file.lastModified(); + long lastModified = pathname.getLastModified(); if (lastModified == 0) return NIL; return number(lastModified / 1000 + 2208988800L); Added: trunk/abcl/src/org/armedbear/lisp/unzip.java ============================================================================== --- (empty file) +++ trunk/abcl/src/org/armedbear/lisp/unzip.java Sat Feb 6 05:52:32 2010 @@ -0,0 +1,121 @@ +/* + * unzip.java + * + * Copyright (C) 2010 Mark Evenson + * $Id: unzip.java 12288 2009-11-29 22:00:12Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import static org.armedbear.lisp.Lisp.*; +import java.io.File; +import java.io.InputStream; +import java.io.FileOutputStream; +import java.io.IOException; +import java.util.Enumeration; +import java.util.zip.ZipEntry; +import java.util.zip.ZipFile; + +// ### unzip pathname directory => unzipped_pathnames +public final class unzip + extends Primitive +{ + public unzip() { + super("unzip", PACKAGE_SYS, true, "pathname &optional directory => unzipped_pathnames"); + } + + @Override + public LispObject execute(LispObject first) { + Pathname zipFile = coerceToPathname(first); + Pathname directory = coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue()); + return unzipToDirectory(zipFile, directory); + } + + @Override + public LispObject execute(LispObject first, LispObject second) { + Pathname zipFile = coerceToPathname(first); + Pathname directory = coerceToPathname(second); + directory.name = NIL; + directory.type = NIL; + directory.invalidateNamestring(); + return unzipToDirectory(zipFile, directory); + } + + private LispObject unzipToDirectory(Pathname zipPath, Pathname dirPath) { + if (!zipPath.isAbsolute()) { + zipPath = Pathname.mergePathnames(zipPath, + coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue())); + } + LispObject o = Pathname.truename(zipPath, false); + if (!(o instanceof Pathname)) { + return error(new FileError("No file found: " + zipPath, zipPath)); + } + String zip = ((Pathname)o).getNamestring(); + if (zip == null) { + return error(new FileError("Pathname has no namestring: " + zip, zipPath)); + } + String dir = dirPath.getNamestring(); + if (dir == null) { + return error(new FileError("Could not parse diretory: " + dirPath, dirPath)); + } + LispObject result = NIL; + try { + ZipFile zipfile = new ZipFile(zip); + + byte[] buffer = new byte[4096]; + for (Enumeration entries = zipfile.entries();entries.hasMoreElements();) { + ZipEntry entry = entries.nextElement(); + String name = entry.getName(); + String filename = dir + name; + File file = new File(filename); + if (entry.isDirectory()) { + file.mkdirs(); + continue; + } + FileOutputStream out = new FileOutputStream(file); + InputStream in = zipfile.getInputStream(entry); + int n; + while ((n = in.read(buffer)) > 0) { + out.write(buffer, 0, n); + } + out.close(); + in.close(); + result = result.push(new Pathname(filename)); + } + } catch (IOException e) { + return error(new FileError("Failed to unzip " + + "'" + zipPath + "'" + + " into " + "'" + dirPath + "'" + + ": " + e, zipPath)); + } + return result; + } + + private static final Primitive unzip = new unzip(); +} From mevenson at common-lisp.net Sat Feb 6 15:20:32 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 06 Feb 2010 10:20:32 -0500 Subject: [armedbear-cvs] r12423 - trunk/abcl Message-ID: Author: mevenson Date: Sat Feb 6 10:20:29 2010 New Revision: 12423 Log: Improve Ant knobs documentation. Modified: trunk/abcl/build.properties.in Modified: trunk/abcl/build.properties.in ============================================================================== --- trunk/abcl/build.properties.in (original) +++ trunk/abcl/build.properties.in Sat Feb 6 10:20:29 2010 @@ -1,11 +1,14 @@ # build.properties # $Id: build.properties,v 1.23 2007-03-03 19:19:11 piso Exp $ -# Contents show up in JAR Manifest in the Implementation-Source attribute -#version.src=[abcl] +# version.src contents show up in JAR Manifest in the Implementation-Source attribute +#version.src=[abcl svn] -# If set, ABCL attempts to perform incremental compilation +# abcl.build.incremental attempts to perform incremental compilation #abcl.build.incremental=true -# Skip the compilation of Lisp sources (for debugging) +# abcl.compile.lisp.skip skips the compilation of Lisp sources in Netbeans (for debugging) #abcl.compile.lisp.skip=true + +# java.options sets the Java options in the abcl wrapper scripts +#java.options=-Xmx1g \ No newline at end of file From mevenson at common-lisp.net Sat Feb 6 15:22:48 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 06 Feb 2010 10:22:48 -0500 Subject: [armedbear-cvs] r12424 - in trunk/abcl/test: lisp/abcl src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat Feb 6 10:22:47 2010 New Revision: 12424 Log: Further tests for jar pathnames. jar-file.lisp now has network based FASL loads. Additional associated Java unit tests. Added: trunk/abcl/test/src/org/armedbear/lisp/UtilitiesTest.java Modified: trunk/abcl/test/lisp/abcl/jar-file.lisp trunk/abcl/test/src/org/armedbear/lisp/PathnameTest.java trunk/abcl/test/src/org/armedbear/lisp/StreamTest.java Modified: trunk/abcl/test/lisp/abcl/jar-file.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/jar-file.lisp (original) +++ trunk/abcl/test/lisp/abcl/jar-file.lisp Sat Feb 6 10:22:47 2010 @@ -128,6 +128,50 @@ (load "jar:file:baz.jar!/a/b/eek.lisp")) t) +;;; wrapped in PROGN for easy disabling without a network connection +;;; XXX come up with a better abstraction +(progn + (deftest jar-file.load.11 + (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/foo") + t) + + (deftest jar-file.load.12 + (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/bar") + t) + + (deftest jar-file.load.13 + (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/bar.abcl") + t) + + (deftest jar-file.load.14 + (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/eek") + t) + + (deftest jar-file.load.15 + (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/eek.lisp") + t) + + (deftest jar-file.load.16 + (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/foo") + t) + + (deftest jar-file.load.17 + (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/bar") + t) + + (deftest jar-file.load.18 + (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/bar.abcl") + t) + + (deftest jar-file.load.19 + (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/eek") + t) + + (deftest jar-file.load.20 + (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/eek.lisp") + t)) + + (deftest jar-file.probe-file.1 (with-jar-file-init (probe-file "jar:file:baz.jar!/eek.lisp")) @@ -164,7 +208,7 @@ (deftest jar-file.merge-pathnames.2 (merge-pathnames - "/bar.abcl" #p"jar:file:baz.jar!/foo/") + "bar.abcl" #p"jar:file:baz.jar!/foo/") #p"jar:file:baz.jar!/foo/bar.abcl") (deftest jar-file.merge-pathnames.3 @@ -172,6 +216,11 @@ "jar:file:baz.jar!/foo" "bar") #p"jar:file:baz.jar!/foo") +(deftest jar-file.merge-pathnames.4 + (merge-pathnames + "jar:file:baz.jar!/foo" "/a/b/c") + #p"jar:file:/a/b/baz.jar!/foo") + (deftest jar-file.truename.1 (signals-error (truename "jar:file:baz.jar!/foo") 'file-error) Modified: trunk/abcl/test/src/org/armedbear/lisp/PathnameTest.java ============================================================================== --- trunk/abcl/test/src/org/armedbear/lisp/PathnameTest.java (original) +++ trunk/abcl/test/src/org/armedbear/lisp/PathnameTest.java Sat Feb 6 10:22:47 2010 @@ -38,7 +38,7 @@ @Test public void getInputStream() throws IOException { - File file = File.createTempFile("foo", "lisp"); + File file = File.createTempFile("foo", ".lisp"); FileWriter output = new FileWriter(file); String contents = "(defun foo () 42)"; output.append(contents); @@ -53,6 +53,52 @@ result.append(buffer, 0, i); } assertEquals(contents, result.toString()); + input.close(); file.delete(); } + + @Test + public void copyConstructor() { + Pathname orig = new Pathname("/a/b/c/d/e/foo.lisp"); + Pathname copy = new Pathname(orig.getNamestring()); + assertTrue(orig.getNamestring().equals(copy.getNamestring())); + } + + @Test + public void mergePathnames1() { + Pathname p = new Pathname("a/b/c/d/foo.lisp"); + Pathname d = new Pathname("/foo/bar/there"); + Pathname r = Pathname.mergePathnames(p, d); + String s = r.getNamestring(); + assertTrue(s.equals("/foo/bar/a/b/c/d/foo.lisp")); + } + + @Test + public void mergePathnames2() { + Pathname p = new Pathname("/a/b/c/d/foo.lisp"); + Pathname d = new Pathname("/foo/bar/there"); + Pathname r = Pathname.mergePathnames(p, d); + assertTrue(r.getNamestring().equals("/a/b/c/d/foo.lisp")); + } + + @Test + public void mergePathnames3() { + LispObject args = Lisp.NIL; + args = args.push(Keyword.TYPE); + args = args.push(new SimpleString("abcl-tmp")); + args = args.nreverse(); + Pathname p = Pathname.makePathname(args); + Pathname d = new Pathname("/foo/bar.abcl"); + Pathname r = Pathname.mergePathnames(p, d); + assertTrue(r.getNamestring().equals("/foo/bar.abcl-tmp")); + } + + @Test + public void mergePathnames4() { + Pathname p = new Pathname("jar:file:foo.jar!/bar.abcl"); + Pathname d = new Pathname("/a/b/c/"); + Pathname r = Pathname.mergePathnames(p, d); + String s = r.getNamestring(); + assertTrue(s.equals("jar:file:/a/b/c/foo.jar!/bar.abcl")); + } } Modified: trunk/abcl/test/src/org/armedbear/lisp/StreamTest.java ============================================================================== --- trunk/abcl/test/src/org/armedbear/lisp/StreamTest.java (original) +++ trunk/abcl/test/src/org/armedbear/lisp/StreamTest.java Sat Feb 6 10:22:47 2010 @@ -26,6 +26,7 @@ Stream in = new Stream(Symbol.SYSTEM_STREAM, pathname.getInputStream(), Symbol.CHARACTER); LispObject o = in.read(false, Lisp.EOF, false, LispThread.currentThread()); assertFalse(o.equals(Lisp.NIL)); + in._close(); file.delete(); } } \ No newline at end of file Added: trunk/abcl/test/src/org/armedbear/lisp/UtilitiesTest.java ============================================================================== --- (empty file) +++ trunk/abcl/test/src/org/armedbear/lisp/UtilitiesTest.java Sat Feb 6 10:22:47 2010 @@ -0,0 +1,53 @@ +package org.armedbear.lisp; + +import java.io.FileNotFoundException; +import static org.junit.Assert.*; + +import java.io.File; +import java.io.FileInputStream; +import java.io.FileWriter; +import org.junit.Test; +import java.io.IOException; +import java.io.InputStream; +import java.util.jar.JarFile; +import java.util.jar.JarInputStream; +import java.util.zip.ZipEntry; +import java.util.zip.ZipInputStream; +import org.junit.Before; + +public class UtilitiesTest +{ + File zipFile; + + + @Before + public void setup() { + // XXX currently created by the ABCL Lisp based tests + zipFile = new File("test/lisp/abcl/baz.jar"); + assertTrue(zipFile.canRead()); + } + + + @Test + public void getZipEntry() throws FileNotFoundException, IOException { + FileInputStream inputFile = new FileInputStream(zipFile); + ZipInputStream input = new ZipInputStream(inputFile); + ZipEntry entry = Utilities.getEntry(input, "a/b/bar.abcl"); + assertNotNull(entry); + input.close(); + inputFile.close(); + } + + @Test + public void getZipInputStreamZipEntry() throws FileNotFoundException, IOException { + JarFile jar = new JarFile(zipFile); + Pathname pathname = new Pathname("a/b/bar.abcl"); + InputStream entryInputStream = Utilities.getInputStream(jar, pathname); + assertNotNull(entryInputStream); + ZipInputStream zip = new ZipInputStream(entryInputStream); + assertNotNull(zip); + ZipEntry entry = Utilities.getEntry(zip, "bar._"); + assertNotNull(entry); + } + +} \ No newline at end of file From ehuelsmann at common-lisp.net Sat Feb 6 17:00:36 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 06 Feb 2010 12:00:36 -0500 Subject: [armedbear-cvs] r12425 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Feb 6 12:00:32 2010 New Revision: 12425 Log: No longer ignore the METACLASS defclass option; instead act on it upon class creation. 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 Sat Feb 6 12:00:32 2010 @@ -537,7 +537,14 @@ (defun canonical-slot-name (canonical-slot) (getf canonical-slot :name)) -(defun ensure-class (name &rest all-keys &allow-other-keys) +(defun ensure-class (name &rest all-keys + &key (metaclass 'standard-class) &allow-other-keys) + + ;; Don't pass METACLASS on to the initialization routines + ;; This only works because we *know* ABCL conses up new &rest lists + ;; every time; otherwise, modifying the argument list is discouraged by the spec + (remf all-keys :metaclass) + ;; Check for duplicate slots. (let ((slots (getf all-keys :direct-slots))) (dolist (s1 slots) @@ -582,8 +589,12 @@ (apply #'std-after-initialization-for-classes old-class all-keys) old-class))) (t - (let ((class (apply #'make-instance-standard-class - (find-class 'standard-class) + (let ((class (apply (if (eq metaclass 'standard-class) + #'make-instance-standard-class + #'make-instance) + (or (when (symbolp metaclass) + (find-class metaclass)) + metaclass) :name name all-keys))) (%set-find-class name class) class))))) From mevenson at common-lisp.net Sun Feb 7 09:21:29 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 07 Feb 2010 04:21:29 -0500 Subject: [armedbear-cvs] r12426 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun Feb 7 04:21:26 2010 New Revision: 12426 Log: ABCL packed FASLS no longer have to end in ".abcl". The requirement that packed FASLS had to end in ".abcl" was introduced in the recent Pathname code as a optimization to avoid opening/closing an input stream on the assumption that renaming FASLs would not be expected to work. But COMPILE-FILE has an :OUTPUT-FILE arg that certainly can be used, so we relax this restriction. Found by dmiles in the ANSI test suite. Modified: trunk/abcl/src/org/armedbear/lisp/Load.java Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Sun Feb 7 04:21:26 2010 @@ -151,34 +151,32 @@ } } - if (truename.type.getStringValue().equals(COMPILE_FILE_TYPE) - && Utilities.checkZipFile(truename)) - { - String n = truename.getNamestring(); - if (n.startsWith("jar:")) { - n = "jar:" + n + "!/" + truename.name.getStringValue() + "." - + COMPILE_FILE_INIT_FASL_TYPE; + if (Utilities.checkZipFile(truename)) { + String n = truename.getNamestring(); + if (n.startsWith("jar:")) { + n = "jar:" + n + "!/" + truename.name.getStringValue() + "." + + COMPILE_FILE_INIT_FASL_TYPE; + } else { + n = "jar:file:" + n + "!/" + truename.name.getStringValue() + "." + + COMPILE_FILE_INIT_FASL_TYPE; + } + mergedPathname = new Pathname(n); + LispObject initTruename = Pathname.truename(mergedPathname); + if (initTruename == null || initTruename.equals(NIL)) { + String errorMessage + = "Loadable FASL not found for" + + "'" + pathname + "'" + + " in " + + "'" + mergedPathname + "'"; + if (ifDoesNotExist) { + return error(new FileError(errorMessage, mergedPathname)); } else { - n = "jar:file:" + n + "!/" + truename.name.getStringValue() + "." - + COMPILE_FILE_INIT_FASL_TYPE; + Debug.trace(errorMessage); + return NIL; } - mergedPathname = new Pathname(n); - LispObject initTruename = Pathname.truename(mergedPathname); - if (initTruename == null || initTruename.equals(NIL)) { - String errorMessage - = "Loadable FASL not found for" - + "'" + pathname + "'" - + " in " - + "'" + mergedPathname + "'"; - if (ifDoesNotExist) { - return error(new FileError(errorMessage, mergedPathname)); - } else { - Debug.trace(errorMessage); - return NIL; - } - } - truename = (Pathname)initTruename; } + truename = (Pathname)initTruename; + } InputStream in = truename.getInputStream(); Debug.assertTrue(in != null); From mevenson at common-lisp.net Sun Feb 7 16:46:49 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 07 Feb 2010 11:46:49 -0500 Subject: [armedbear-cvs] r12427 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun Feb 7 11:46:47 2010 New Revision: 12427 Log: Fix ClassCastException occuring when LOAD from streams. Modified: trunk/abcl/src/org/armedbear/lisp/Load.java Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Sun Feb 7 11:46:47 2010 @@ -404,31 +404,51 @@ final String prefix = getLoadVerbosePrefix(loadDepth); try { thread.bindSpecial(Symbol.LOAD_PATHNAME, pathname); - Pathname truePathname = new Pathname(((Pathname)truename).getNamestring()); - String type = truePathname.type.getStringValue(); - if (type.equals(COMPILE_FILE_TYPE) - || type.equals(COMPILE_FILE_INIT_FASL_TYPE.toString())) { - thread.bindSpecial(Symbol.LOAD_TRUENAME_FASL, truePathname); - } - if (truePathname.type.getStringValue().equals(COMPILE_FILE_INIT_FASL_TYPE.getStringValue()) - && truePathname.isJar()) { - if (truePathname.device.cdr() != NIL ) { - // set truename to the enclosing JAR - truePathname.host = NIL; - truePathname.directory = NIL; - truePathname.name = NIL; - truePathname.type = NIL; - truePathname.invalidateNamestring(); - } else { - // XXX There is something fishy in the asymmetry - // between the "jar:jar:http:" and "jar:jar:file:" - // cases but this currently passes the tests. - if (!(truePathname.device.car() instanceof AbstractString)) { - truePathname = (Pathname)truePathname.device.car(); - truePathname.invalidateNamestring(); + + // The motivation behind the following piece of complexity + // is the need to preserve the semantics of + // *LOAD-TRUENAME* as always containing the truename of + // the current "Lisp file". Since an ABCL packed FASL + // actually has a Lisp file (aka "the init FASL") and one + // or more Java classes from the compiler, we endeavor to + // make *LOAD-TRUENAME* refer to the "overall" truename so + // that a (LOAD *LOAD-TRUENAME*) would be equivalent to + // reloading the complete current "Lisp file". If this + // value diverges from the "true" truename, we set the + // symbol SYS::*LOAD-TRUENAME-FASL* to that divergent + // value. Currently the only code that uses this value is + // Lisp.readFunctionBytes(). + Pathname truePathname = null; + if (!truename.equals(NIL)) { + truePathname = new Pathname(((Pathname)truename).getNamestring()); + String type = truePathname.type.getStringValue(); + if (type.equals(COMPILE_FILE_TYPE) + || type.equals(COMPILE_FILE_INIT_FASL_TYPE.toString())) { + thread.bindSpecial(Symbol.LOAD_TRUENAME_FASL, truePathname); + } + if (truePathname.type.getStringValue() + .equals(COMPILE_FILE_INIT_FASL_TYPE.getStringValue()) + && truePathname.isJar()) { + if (truePathname.device.cdr() != NIL ) { + // set truename to the enclosing JAR + truePathname.host = NIL; + truePathname.directory = NIL; + truePathname.name = NIL; + truePathname.type = NIL; + truePathname.invalidateNamestring(); + } else { + // XXX There is something fishy in the asymmetry + // between the "jar:jar:http:" and "jar:jar:file:" + // cases but this currently passes the tests. + if (!(truePathname.device.car() instanceof AbstractString)) { + truePathname = (Pathname)truePathname.device.car(); + truePathname.invalidateNamestring(); + } } - } - thread.bindSpecial(Symbol.LOAD_TRUENAME, truePathname); + thread.bindSpecial(Symbol.LOAD_TRUENAME, truePathname); + } else { + thread.bindSpecial(Symbol.LOAD_TRUENAME, truename); + } } else { thread.bindSpecial(Symbol.LOAD_TRUENAME, truename); } From astalla at common-lisp.net Sun Feb 7 22:08:05 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Sun, 07 Feb 2010 17:08:05 -0500 Subject: [armedbear-cvs] r12428 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Sun Feb 7 17:08:01 2010 New Revision: 12428 Log: Corrected bugs: inline declaration for local functions was ignored as for r12420, and the bug r12420 was supposed to fix has been fixed, too. 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 Feb 7 17:08:01 2010 @@ -51,10 +51,7 @@ (if args-p (expand-function-call-inline nil lambda-list - (copy-tree `((block ,name - (locally - (declare (notinline ,name)) - , at body)))) + (copy-tree `((block ,name , at body))) args) (cond ((intersection lambda-list '(&optional &rest &key &allow-other-keys &aux) @@ -927,20 +924,18 @@ (p1-compiland compiland))) (push local-function local-functions))) ((with-saved-compiler-policy - (let ((inline-decls *inline-declarations*)) - (process-optimization-declarations (cddr form)) - (let* ((block (make-flet-node)) - (*blocks* (cons block *blocks*)) - (body (cddr form)) - (*visible-variables* *visible-variables*)) - (setf (flet-free-specials block) - (process-declarations-for-vars body nil block)) - (dolist (special (flet-free-specials block)) - (push special *visible-variables*)) - (setf (flet-form block) - (let ((*inline-declarations* inline-decls)) - (list* (car form) local-functions (p1-body (cddr form))))) - block)))))) + (process-optimization-declarations (cddr form)) + (let* ((block (make-flet-node)) + (*blocks* (cons block *blocks*)) + (body (cddr form)) + (*visible-variables* *visible-variables*)) + (setf (flet-free-specials block) + (process-declarations-for-vars body nil block)) + (dolist (special (flet-free-specials block)) + (push special *visible-variables*)) + (setf (flet-form block) + (list* (car form) local-functions (p1-body (cddr form)))) + block))))) (defun p1-labels (form) @@ -951,6 +946,8 @@ :compiland compiland :variable variable)) (block-name (fdefinition-block-name name))) + (setf (local-function-definition local-function) + (copy-tree (cons lambda-list body))) (multiple-value-bind (body decls) (parse-body body) (setf (compiland-lambda-expression compiland) (rewrite-lambda @@ -1287,7 +1284,6 @@ (cond (local-function ;; (format t "p1 local call to ~S~%" op) ;; (format t "inline-p = ~S~%" (inline-p op)) - (when (and *enable-inline-expansion* (inline-p op) (local-function-definition local-function)) (let* ((definition (local-function-definition local-function)) @@ -1300,7 +1296,9 @@ (when (and explain (memq :calls explain)) (format t "; inlining call to local function ~S~%" op))) (return-from p1-function-call - (p1 expansion))))) + (let ((*inline-declarations* + (remove op *inline-declarations* :key #'car))) + (p1 expansion)))))) ;; FIXME (dformat t "local function assumed not single-valued~%") From mevenson at common-lisp.net Mon Feb 8 07:43:41 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 08 Feb 2010 02:43:41 -0500 Subject: [armedbear-cvs] r12429 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Feb 8 02:43:38 2010 New Revision: 12429 Log: Correct svn:eol-style and svn:keywords. Modified: trunk/abcl/src/org/armedbear/lisp/CharHashMap.java (props changed) trunk/abcl/src/org/armedbear/lisp/JavaClass.java (contents, props changed) trunk/abcl/src/org/armedbear/lisp/LICENSE (props changed) trunk/abcl/src/org/armedbear/lisp/LispInteger.java (contents, props changed) trunk/abcl/src/org/armedbear/lisp/asdf-abcl.lisp (contents, props changed) trunk/abcl/src/org/armedbear/lisp/unzip.java (contents, props changed) Modified: trunk/abcl/src/org/armedbear/lisp/JavaClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JavaClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/JavaClass.java Mon Feb 8 02:43:38 2010 @@ -2,7 +2,7 @@ * BuiltInClass.java * * Copyright (C) 2003-2007 Peter Graves - * $Id: BuiltInClass.java 11297 2008-08-31 13:26:45Z ehuelsmann $ + * $Id$ * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License Modified: trunk/abcl/src/org/armedbear/lisp/LispInteger.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispInteger.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispInteger.java Mon Feb 8 02:43:38 2010 @@ -1,54 +1,54 @@ -/* - * LispInteger.java - * - * Copyright (C) 2003-2007 Peter Graves - * $Id: Bignum.java 11573 2009-01-21 22:14:47Z ehuelsmann $ - * - * 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; - -/** This class merely serves as the super class for - * Fixnum and Bignum - */ -public class LispInteger extends LispObject -{ - - public static LispInteger getInstance(long l) { - if (Integer.MIN_VALUE <= l && l <= Integer.MAX_VALUE) - return Fixnum.getInstance((int)l); - else - return Bignum.getInstance(l); - } - - public static LispInteger getInstance(int i) { - return Fixnum.getInstance(i); - } - - -} +/* + * LispInteger.java + * + * Copyright (C) 2003-2007 Peter Graves + * $Id$ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +/** This class merely serves as the super class for + * Fixnum and Bignum + */ +public class LispInteger extends LispObject +{ + + public static LispInteger getInstance(long l) { + if (Integer.MIN_VALUE <= l && l <= Integer.MAX_VALUE) + return Fixnum.getInstance((int)l); + else + return Bignum.getInstance(l); + } + + public static LispInteger getInstance(int i) { + return Fixnum.getInstance(i); + } + + +} Modified: trunk/abcl/src/org/armedbear/lisp/asdf-abcl.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf-abcl.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/asdf-abcl.lisp Mon Feb 8 02:43:38 2010 @@ -1,7 +1,7 @@ ;;; asdf-abcl.lisp ;;; ;;; Copyright (C) 2010 Mark Evenson -;;; $Id: package.lisp 12418 2010-02-05 15:41:42Z mevenson $ +;;; $Id$ ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License Modified: trunk/abcl/src/org/armedbear/lisp/unzip.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/unzip.java (original) +++ trunk/abcl/src/org/armedbear/lisp/unzip.java Mon Feb 8 02:43:38 2010 @@ -2,7 +2,7 @@ * unzip.java * * Copyright (C) 2010 Mark Evenson - * $Id: unzip.java 12288 2009-11-29 22:00:12Z vvoutilainen $ + * $Id$ * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License From mevenson at common-lisp.net Mon Feb 8 07:46:59 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 08 Feb 2010 02:46:59 -0500 Subject: [armedbear-cvs] r12430 - trunk/abcl Message-ID: Author: mevenson Date: Mon Feb 8 02:46:58 2010 New Revision: 12430 Log: Lisp compilation no longer writes build to temporary file. The way to not confuse ABCL under Windows that pathnames starting in a drive letter are not Lisp packages is solved by using the 'inputstring' attribute to the task. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Mon Feb 8 02:46:58 2010 @@ -220,43 +220,19 @@ + - - - - - - (compile-system :zip nil :quit t - :output-path "${toString:abcl.lisp.output.path}${file.separator}") - - - - - - - - - - - - - - - Finished recording test output in ${abcl.test.log.file}. - + Author: mevenson Date: Mon Feb 8 03:05:15 2010 New Revision: 12431 Log: Replace FastStringBuffer with java.lang.StringBuilder. Phil Hudson suggested in Feburary 2009 that "[FastStringBuffer] should be removed with all references to it replaced with java.lang.StringBuilder once enough confidence in this change has been gained." After almost a year of using FastStringBuffer as a delagate for StringBuilder, that confidence has indeed been gained. One subtlety for use of StringBuilder: there is no StringBuilder(char) constructor, so use StringBuilder(String.valueOf(c)) to construct a new StringBuilder containing a single char. Otherwise that char will get promoted to an int, and you will invoke StringBuilder(int capacity) which will "swallow" the first character that you thought you were adding. Removed: trunk/abcl/src/org/armedbear/lisp/FastStringBuffer.java trunk/abcl/test/src/org/armedbear/lisp/FastStringBufferTest.java Modified: trunk/abcl/src/org/armedbear/lisp/AbstractString.java trunk/abcl/src/org/armedbear/lisp/AbstractVector.java trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java trunk/abcl/src/org/armedbear/lisp/Complex.java trunk/abcl/src/org/armedbear/lisp/Cons.java trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java trunk/abcl/src/org/armedbear/lisp/FaslReader.java trunk/abcl/src/org/armedbear/lisp/Fixnum.java trunk/abcl/src/org/armedbear/lisp/HashTable.java trunk/abcl/src/org/armedbear/lisp/Interpreter.java trunk/abcl/src/org/armedbear/lisp/Java.java trunk/abcl/src/org/armedbear/lisp/JavaClass.java trunk/abcl/src/org/armedbear/lisp/JavaObject.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/LispCharacter.java trunk/abcl/src/org/armedbear/lisp/LispClass.java trunk/abcl/src/org/armedbear/lisp/LispObject.java trunk/abcl/src/org/armedbear/lisp/LispReader.java trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/LogicalPathname.java trunk/abcl/src/org/armedbear/lisp/Package.java trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/PrintNotReadable.java trunk/abcl/src/org/armedbear/lisp/Readtable.java trunk/abcl/src/org/armedbear/lisp/Return.java trunk/abcl/src/org/armedbear/lisp/ShellCommand.java trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java trunk/abcl/src/org/armedbear/lisp/SimpleString.java trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java trunk/abcl/src/org/armedbear/lisp/StandardMethod.java trunk/abcl/src/org/armedbear/lisp/Stream.java trunk/abcl/src/org/armedbear/lisp/StringFunctions.java trunk/abcl/src/org/armedbear/lisp/StructureObject.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/Time.java trunk/abcl/src/org/armedbear/lisp/TypeError.java trunk/abcl/src/org/armedbear/lisp/UnboundSlot.java trunk/abcl/src/org/armedbear/lisp/UndefinedFunction.java trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/delete_file.java trunk/abcl/src/org/armedbear/lisp/make_array.java Modified: trunk/abcl/src/org/armedbear/lisp/AbstractString.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/AbstractString.java (original) +++ trunk/abcl/src/org/armedbear/lisp/AbstractString.java Mon Feb 8 03:05:15 2010 @@ -96,7 +96,7 @@ if (Symbol.PRINT_ESCAPE.symbolValue(thread) != NIL || Symbol.PRINT_READABLY.symbolValue(thread) != NIL) { - FastStringBuffer sb = new FastStringBuffer('"'); + StringBuilder sb = new StringBuilder("\""); for (int i = beginIndex; i < endIndex; i++) { char c = charAt(i); if (c == '\"' || c == '\\') Modified: trunk/abcl/src/org/armedbear/lisp/AbstractVector.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/AbstractVector.java (original) +++ trunk/abcl/src/org/armedbear/lisp/AbstractVector.java Mon Feb 8 03:05:15 2010 @@ -151,7 +151,7 @@ protected void badIndex(int index, int limit) { - FastStringBuffer sb = new FastStringBuffer("Invalid array index "); + StringBuilder sb = new StringBuilder("Invalid array index "); sb.append(index); sb.append(" for "); sb.append(writeToString()); @@ -209,7 +209,7 @@ final LispThread thread = LispThread.currentThread(); if (Symbol.PRINT_READABLY.symbolValue(thread) != NIL) { - FastStringBuffer sb = new FastStringBuffer("#("); + StringBuilder sb = new StringBuilder("#("); final int limit = length(); for (int i = 0; i < limit; i++) { Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java Mon Feb 8 03:05:15 2010 @@ -73,7 +73,7 @@ @Override public String writeToString() { - FastStringBuffer sb = new FastStringBuffer("#'); return sb.toString(); 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 Mon Feb 8 03:05:15 2010 @@ -336,7 +336,7 @@ @Override public String writeToString() { - FastStringBuffer sb = new FastStringBuffer("#C("); + StringBuilder sb = new StringBuilder("#C("); sb.append(realpart.writeToString()); sb.append(' '); sb.append(imagpart.writeToString()); Modified: trunk/abcl/src/org/armedbear/lisp/Cons.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Cons.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Cons.java Mon Feb 8 03:05:15 2010 @@ -576,7 +576,7 @@ maxLevel = ((Fixnum)printLevel).value; else maxLevel = Integer.MAX_VALUE; - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); if (car == Symbol.QUOTE) { if (cdr instanceof Cons) Modified: trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java (original) +++ trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java Mon Feb 8 03:05:15 2010 @@ -572,12 +572,12 @@ public String writeToString() { if (value == Double.POSITIVE_INFINITY) { - FastStringBuffer sb = new FastStringBuffer("#."); + StringBuilder sb = new StringBuilder("#."); sb.append(Symbol.DOUBLE_FLOAT_POSITIVE_INFINITY.writeToString()); return sb.toString(); } if (value == Double.NEGATIVE_INFINITY) { - FastStringBuffer sb = new FastStringBuffer("#."); + StringBuilder sb = new StringBuilder("#."); sb.append(Symbol.DOUBLE_FLOAT_NEGATIVE_INFINITY.writeToString()); return sb.toString(); } Modified: trunk/abcl/src/org/armedbear/lisp/FaslReader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FaslReader.java (original) +++ trunk/abcl/src/org/armedbear/lisp/FaslReader.java Mon Feb 8 03:05:15 2010 @@ -73,7 +73,7 @@ { final Readtable rt = FaslReadtable.getInstance(); - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); try { while (true) { @@ -222,7 +222,7 @@ final Readtable rt = FaslReadtable.getInstance(); final boolean suppress = (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL); - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); try { while (true) { @@ -474,8 +474,8 @@ public LispObject execute(Stream stream, char c, int n) { - FastStringBuffer sb = - new FastStringBuffer("Illegal # macro character: #\\"); + StringBuilder sb = + new StringBuilder("Illegal # macro character: #\\"); String s = LispCharacter.charToName(c); if (s != null) sb.append(s); Modified: trunk/abcl/src/org/armedbear/lisp/Fixnum.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Fixnum.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Fixnum.java Mon Feb 8 03:05:15 2010 @@ -946,7 +946,7 @@ String s = Integer.toString(value, base).toUpperCase(); if (Symbol.PRINT_RADIX.symbolValue(thread) != NIL) { - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); switch (base) { case 2: 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 Mon Feb 8 03:05:15 2010 @@ -234,7 +234,7 @@ error(new PrintNotReadable(list(Keyword.OBJECT, this))); return null; // Not reached. } - FastStringBuffer sb = new FastStringBuffer(getTest().writeToString()); + StringBuilder sb = new StringBuilder(getTest().writeToString()); sb.append(' '); sb.append(Symbol.HASH_TABLE.writeToString()); sb.append(' '); Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Interpreter.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Interpreter.java Mon Feb 8 03:05:15 2010 @@ -259,7 +259,7 @@ catch (UnhandledCondition c) { final String separator = System.getProperty("line.separator"); - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); sb.append(separator); sb.append("Caught "); sb.append(c.getCondition().typeOf().writeToString()); @@ -541,7 +541,7 @@ private static String banner() { final String sep = System.getProperty("line.separator"); - FastStringBuffer sb = new FastStringBuffer("Armed Bear Common Lisp "); + StringBuilder sb = new StringBuilder("Armed Bear Common Lisp "); sb.append(Version.getVersion()); if (build != null) { sb.append(" (built "); Modified: trunk/abcl/src/org/armedbear/lisp/Java.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Java.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Java.java Mon Feb 8 03:05:15 2010 @@ -323,7 +323,7 @@ throw new NoSuchMethodException(); } catch (NoSuchMethodException e) { - FastStringBuffer sb = new FastStringBuffer("No such method: "); + StringBuilder sb = new StringBuilder("No such method: "); sb.append(c.getName()); sb.append('.'); sb.append(methodName); Modified: trunk/abcl/src/org/armedbear/lisp/JavaClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JavaClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/JavaClass.java Mon Feb 8 03:05:15 2010 @@ -96,7 +96,7 @@ } public String writeToString() { - FastStringBuffer sb = new FastStringBuffer("#'); return sb.toString(); Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JavaObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/JavaObject.java Mon Feb 8 03:05:15 2010 @@ -303,8 +303,8 @@ final String s; if(obj != null) { Class c = obj.getClass(); - FastStringBuffer sb - = new FastStringBuffer(c.isArray() ? "jarray" : c.getName()); + StringBuilder sb + = new StringBuilder(c.isArray() ? "jarray" : c.getName()); sb.append(' '); String ts = obj.toString(); if(ts.length() > 32) { //random value, should be chosen sensibly @@ -436,8 +436,8 @@ public static String describeJavaObject(final JavaObject javaObject) { final Object obj = javaObject.getObject(); - final FastStringBuffer sb = - new FastStringBuffer(javaObject.writeToString()); + final StringBuilder sb = + new StringBuilder(javaObject.writeToString()); sb.append(" is an object of type "); sb.append(Symbol.JAVA_OBJECT.writeToString()); sb.append("."); 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 Feb 8 03:05:15 2010 @@ -1063,7 +1063,7 @@ public static final Symbol gensym(String prefix, LispThread thread) { - FastStringBuffer sb = new FastStringBuffer(prefix); + StringBuilder sb = new StringBuilder(prefix); SpecialBinding binding = thread.getSpecialBinding(Symbol.GENSYM_COUNTER); final LispObject oldValue; if (binding != null) { @@ -1676,7 +1676,7 @@ { if (start < 0 || end < 0 || start > end || end > length) { - FastStringBuffer sb = new FastStringBuffer("The bounding indices "); + StringBuilder sb = new StringBuilder("The bounding indices "); sb.append(start); sb.append(" and "); sb.append(end); Modified: trunk/abcl/src/org/armedbear/lisp/LispCharacter.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispCharacter.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispCharacter.java Mon Feb 8 03:05:15 2010 @@ -96,7 +96,7 @@ @Override public LispObject getDescription() { - FastStringBuffer sb = new FastStringBuffer("character #\\"); + StringBuilder sb = new StringBuilder("character #\\"); sb.append(value); sb.append(" char-code #x"); sb.append(Integer.toHexString(value)); @@ -240,7 +240,7 @@ // false." boolean printEscape = printReadably || (Symbol.PRINT_ESCAPE.symbolValue(thread) != NIL); - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); if (printEscape) { sb.append("#\\"); 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 Mon Feb 8 03:05:15 2010 @@ -77,8 +77,8 @@ return c; if (errorp) { - FastStringBuffer sb = - new FastStringBuffer("There is no class named "); + StringBuilder sb = + new StringBuilder("There is no class named "); sb.append(name.writeToString()); sb.append('.'); return error(new LispError(sb.toString())); Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Mon Feb 8 03:05:15 2010 @@ -64,7 +64,7 @@ public LispObject getDescription() { - FastStringBuffer sb = new FastStringBuffer("An object of type "); + StringBuilder sb = new StringBuilder("An object of type "); sb.append(typeOf().writeToString()); sb.append(" at #x"); sb.append(Integer.toHexString(System.identityHashCode(this)).toUpperCase()); @@ -682,7 +682,7 @@ public String unreadableString(String s, boolean identity) { - FastStringBuffer sb = new FastStringBuffer("#<"); + StringBuilder sb = new StringBuilder("#<"); sb.append(s); if (identity) { sb.append(" {"); Modified: trunk/abcl/src/org/armedbear/lisp/LispReader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispReader.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispReader.java Mon Feb 8 03:05:15 2010 @@ -74,7 +74,7 @@ { final LispThread thread = LispThread.currentThread(); final Readtable rt = (Readtable) Symbol.CURRENT_READTABLE.symbolValue(thread); - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); try { while (true) { @@ -222,7 +222,7 @@ final LispThread thread = LispThread.currentThread(); final Readtable rt = (Readtable) Symbol.CURRENT_READTABLE.symbolValue(thread); final boolean suppress = Symbol.READ_SUPPRESS.symbolValue(thread) != NIL; - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); try { while (true) { @@ -467,7 +467,7 @@ public LispObject execute(Stream stream, char c, int n) { - FastStringBuffer sb = new FastStringBuffer("Illegal # macro character: #\\"); + StringBuilder sb = new StringBuilder("Illegal # macro character: #\\"); String s = LispCharacter.charToName(c); if (s != null) sb.append(s); Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Mon Feb 8 03:05:15 2010 @@ -187,8 +187,8 @@ verbose, print, false, returnLastResult); } catch (FaslVersionMismatch e) { - FastStringBuffer sb = - new FastStringBuffer("Incorrect fasl version: "); + StringBuilder sb = + new StringBuilder("Incorrect fasl version: "); sb.append(truename); return error(new SimpleError(sb.toString())); } @@ -301,8 +301,8 @@ return loadFileFromStream(pathname, truename, stream, verbose, print, auto); } catch (FaslVersionMismatch e) { - FastStringBuffer sb = - new FastStringBuffer("; Incorrect fasl version: "); + StringBuilder sb = + new StringBuilder("; Incorrect fasl version: "); sb.append(truename); System.err.println(sb.toString()); } finally { @@ -483,7 +483,7 @@ public static String getLoadVerbosePrefix(int loadDepth) { - FastStringBuffer sb = new FastStringBuffer(";"); + StringBuilder sb = new StringBuilder(";"); for (int i = loadDepth - 1; i-- > 0;) sb.append(' '); return sb.toString(); Modified: trunk/abcl/src/org/armedbear/lisp/LogicalPathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LogicalPathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LogicalPathname.java Mon Feb 8 03:05:15 2010 @@ -203,7 +203,7 @@ @Override protected String getDirectoryNamestring() { - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); // "If a pathname is converted to a namestring, the symbols NIL and // :UNSPECIFIC cause the field to be treated as if it were empty. That // is, both NIL and :UNSPECIFIC cause the component not to appear in @@ -244,7 +244,7 @@ final LispThread thread = LispThread.currentThread(); boolean printReadably = (Symbol.PRINT_READABLY.symbolValue(thread) != NIL); boolean printEscape = (Symbol.PRINT_ESCAPE.symbolValue(thread) != NIL); - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); if (printReadably || printEscape) sb.append("#P\""); sb.append(host.getStringValue()); 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 Mon Feb 8 03:05:15 2010 @@ -88,7 +88,7 @@ public LispObject getDescription() { if (name != null) { - FastStringBuffer sb = new FastStringBuffer("The "); + StringBuilder sb = new StringBuilder("The "); sb.append(name); sb.append(" package"); return new SimpleString(sb); @@ -405,8 +405,8 @@ if (sym == null) sym = s; else if (sym != s) { - FastStringBuffer sb = - new FastStringBuffer("Uninterning the symbol "); + StringBuilder sb = + new StringBuilder("Uninterning the symbol "); sb.append(symbol.getQualifiedName()); sb.append(" causes a name conflict between "); sb.append(sym.getQualifiedName()); @@ -442,7 +442,7 @@ return; // Nothing to do. Symbol sym = findAccessibleSymbol(symbol.name); if (sym != null && sym != symbol) { - FastStringBuffer sb = new FastStringBuffer("The symbol "); + StringBuilder sb = new StringBuilder("The symbol "); sb.append(sym.getQualifiedName()); sb.append(" is already accessible in package "); sb.append(name); @@ -461,7 +461,7 @@ if (symbol.getPackage() != this) { Symbol sym = findAccessibleSymbol(symbol.name); if (sym != symbol) { - FastStringBuffer sb = new FastStringBuffer("The symbol "); + StringBuilder sb = new StringBuilder("The symbol "); sb.append(symbol.getQualifiedName()); sb.append(" is not accessible in package "); sb.append(name); @@ -482,7 +482,7 @@ pkg.shadowingSymbols.get(symbolName) == sym) { // OK. } else { - FastStringBuffer sb = new FastStringBuffer("The symbol "); + StringBuilder sb = new StringBuilder("The symbol "); sb.append(sym.getQualifiedName()); sb.append(" is already accessible in package "); sb.append(pkg.getName()); @@ -501,7 +501,7 @@ if (externalSymbols.get(symbol.name) == symbol) // Symbol is already exported; there's nothing to do. return; - FastStringBuffer sb = new FastStringBuffer("The symbol "); + StringBuilder sb = new StringBuilder("The symbol "); sb.append(symbol.getQualifiedName()); sb.append(" is not accessible in package "); sb.append(name); @@ -528,7 +528,7 @@ usedPackages = usedPackages.cdr(); } } - FastStringBuffer sb = new FastStringBuffer("The symbol "); + StringBuilder sb = new StringBuilder("The symbol "); sb.append(symbol.getQualifiedName()); sb.append(" is not accessible in package "); sb.append(name); @@ -825,7 +825,7 @@ public String writeToString() { if (_PRINT_FASL_.symbolValue() != NIL && name != null) { - FastStringBuffer sb = new FastStringBuffer("#.(FIND-PACKAGE \""); + StringBuilder sb = new StringBuilder("#.(FIND-PACKAGE \""); sb.append(name); sb.append("\")"); return sb.toString(); @@ -836,7 +836,7 @@ @Override public String toString() { if (name != null) { - FastStringBuffer sb = new FastStringBuffer("#"); return sb.toString(); 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 Mon Feb 8 03:05:15 2010 @@ -470,7 +470,7 @@ if (directory instanceof AbstractString) { Debug.assertTrue(false); } - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); // "If a pathname is converted to a namestring, the symbols NIL and // :UNSPECIFIC cause the field to be treated as if it were empty. That // is, both NIL and :UNSPECIFIC cause the component not to appear in @@ -498,7 +498,7 @@ sb.append("!/"); i = 1; } - FastStringBuffer prefix = new FastStringBuffer(); + StringBuilder prefix = new StringBuilder(); for (; i < jars.length; i++) { prefix.append("jar:"); if (i == 0) { @@ -568,7 +568,7 @@ protected String getDirectoryNamestring() { validateDirectory(true); - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); // "If a pathname is converted to a namestring, the symbols NIL and // :UNSPECIFIC cause the field to be treated as if it were empty. That // is, both NIL and :UNSPECIFIC cause the component not to appear in @@ -733,7 +733,7 @@ } else { useNamestring = false; } - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); if (useNamestring) { if (printReadably || printEscape) { sb.append("#P\""); @@ -1182,7 +1182,7 @@ LispObject second = temp.car(); if (second == Keyword.UP || second == Keyword.BACK) { if (signalError) { - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); sb.append(first.writeToString()); sb.append(" may not be followed immediately by "); sb.append(second.writeToString()); @@ -1683,7 +1683,7 @@ } error: if (errorIfDoesNotExist) { - FastStringBuffer sb = new FastStringBuffer("The file "); + StringBuilder sb = new StringBuilder("The file "); sb.append(pathname.writeToString()); sb.append(" does not exist."); return error(new FileError(sb.toString(), pathname)); @@ -1957,7 +1957,7 @@ @Override public LispObject execute(LispObject arg) { Pathname p = coerceToPathname(arg); - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); if (p.name instanceof AbstractString) { sb.append(p.name.getStringValue()); } else if (p.name == Keyword.WILD) { 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 Feb 8 03:05:15 2010 @@ -2178,8 +2178,8 @@ int rank = array.getRank(); if (rank != args.length - 1) { - FastStringBuffer sb = - new FastStringBuffer("ARRAY-IN-BOUNDS-P: "); + StringBuilder sb = + new StringBuilder("ARRAY-IN-BOUNDS-P: "); sb.append("wrong number of subscripts ("); sb.append(args.length - 1); sb.append(") for array of rank "); @@ -2235,8 +2235,8 @@ array = checkArray( arg); if (array.getRank() == 0) return array.AREF(0); - FastStringBuffer sb = - new FastStringBuffer("Wrong number of subscripts (0) for array of rank "); + StringBuilder sb = + new StringBuilder("Wrong number of subscripts (0) for array of rank "); sb.append(array.getRank()); sb.append('.'); return error(new ProgramError(sb.toString())); @@ -2945,7 +2945,7 @@ int n = ((Fixnum)arg).value; if (n >= 0) { - FastStringBuffer sb = new FastStringBuffer('G'); + StringBuilder sb = new StringBuilder("G"); sb.append(n); // Decimal representation. return new Symbol(new SimpleString(sb)); } @@ -2955,7 +2955,7 @@ BigInteger n = ((Bignum)arg).value; if (n.signum() >= 0) { - FastStringBuffer sb = new FastStringBuffer('G'); + StringBuilder sb = new StringBuilder("G"); sb.append(n.toString()); // Decimal representation. return new Symbol(new SimpleString(sb)); } @@ -4109,7 +4109,7 @@ final int start = Fixnum.getValue(second); if (start < 0) { - FastStringBuffer sb = new FastStringBuffer("Bad start index ("); + StringBuilder sb = new StringBuilder("Bad start index ("); sb.append(start); sb.append(") for SUBSEQ."); error(new TypeError(sb.toString())); @@ -4131,7 +4131,7 @@ final int start = Fixnum.getValue(second); if (start < 0) { - FastStringBuffer sb = new FastStringBuffer("Bad start index ("); + StringBuilder sb = new StringBuilder("Bad start index ("); sb.append(start); sb.append(")."); error(new TypeError(sb.toString())); @@ -4142,7 +4142,7 @@ end = Fixnum.getValue(third); if (start > end) { - FastStringBuffer sb = new FastStringBuffer("Start index ("); + StringBuilder sb = new StringBuilder("Start index ("); sb.append(start); sb.append(") is greater than end index ("); sb.append(end); Modified: trunk/abcl/src/org/armedbear/lisp/PrintNotReadable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/PrintNotReadable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/PrintNotReadable.java Mon Feb 8 03:05:15 2010 @@ -81,7 +81,7 @@ @Override public String getMessage() { - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); LispObject object = UNBOUND_VALUE; object = getInstanceSlotValue(Symbol.OBJECT); if (object != UNBOUND_VALUE) { Modified: trunk/abcl/src/org/armedbear/lisp/Readtable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Readtable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Readtable.java Mon Feb 8 03:05:15 2010 @@ -237,7 +237,7 @@ if (isInvalid(c)) { String name = LispCharacter.charToName(c); - FastStringBuffer sb = new FastStringBuffer("Invalid character"); + StringBuilder sb = new StringBuilder("Invalid character"); if (name != null) { sb.append(" #\\"); Modified: trunk/abcl/src/org/armedbear/lisp/Return.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Return.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Return.java Mon Feb 8 03:05:15 2010 @@ -71,7 +71,7 @@ @Override public LispObject getCondition() { - FastStringBuffer sb = new FastStringBuffer("No block named "); + StringBuilder sb = new StringBuilder("No block named "); sb.append(tag.writeToString()); sb.append(" is currently visible."); return new ControlError(sb.toString()); Modified: trunk/abcl/src/org/armedbear/lisp/ShellCommand.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ShellCommand.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ShellCommand.java Mon Feb 8 03:05:15 2010 @@ -85,7 +85,7 @@ if (command != null) { if (Utilities.isPlatformUnix) { if (directory != null) { - FastStringBuffer sb = new FastStringBuffer("\\cd \""); + StringBuilder sb = new StringBuilder("\\cd \""); sb.append(directory); sb.append("\" && "); sb.append(command); @@ -100,7 +100,7 @@ list.add("cmd.exe"); list.add("/c"); if (directory != null) { - FastStringBuffer sb = new FastStringBuffer("cd /d \""); + StringBuilder sb = new StringBuilder("cd /d \""); sb.append(directory); sb.append("\" && "); sb.append(command); Modified: trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java Mon Feb 8 03:05:15 2010 @@ -253,7 +253,7 @@ final int rank = dimv.length; if (rank != subscripts.length) { - FastStringBuffer sb = new FastStringBuffer("Wrong number of subscripts ("); + StringBuilder sb = new StringBuilder("Wrong number of subscripts ("); sb.append(subscripts.length); sb.append(") for array of rank "); sb.append(rank); @@ -270,7 +270,7 @@ int n = subscripts[i]; if (n < 0 || n >= dim) { - FastStringBuffer sb = new FastStringBuffer("Invalid index "); + StringBuilder sb = new StringBuilder("Invalid index "); sb.append(n); sb.append(" for array "); sb.append(this); 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 Mon Feb 8 03:05:15 2010 @@ -72,9 +72,9 @@ sb.getChars(0, capacity, chars, 0); } - public SimpleString(FastStringBuffer sb) + public SimpleString(StringBuilder sb) { - chars = sb.toCharArray(); + chars = sb.toString().toCharArray(); capacity = chars.length; } @@ -111,7 +111,7 @@ @Override public LispObject getDescription() { - FastStringBuffer sb = new FastStringBuffer("A simple-string ("); + StringBuilder sb = new StringBuilder("A simple-string ("); sb.append(capacity); sb.append(") \""); sb.append(chars); Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java Mon Feb 8 03:05:15 2010 @@ -88,8 +88,8 @@ @Override public String writeToString() { - FastStringBuffer sb = - new FastStringBuffer(Symbol.SLOT_DEFINITION.writeToString()); + StringBuilder sb = + new StringBuilder(Symbol.SLOT_DEFINITION.writeToString()); LispObject name = slots[SlotDefinitionClass.SLOT_INDEX_NAME]; if (name != null && name != NIL) { Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Mon Feb 8 03:05:15 2010 @@ -87,8 +87,8 @@ @Override public String writeToString() { - FastStringBuffer sb = - new FastStringBuffer(Symbol.STANDARD_CLASS.writeToString()); + StringBuilder sb = + new StringBuilder(Symbol.STANDARD_CLASS.writeToString()); if (symbol != null) { sb.append(' '); 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 Mon Feb 8 03:05:15 2010 @@ -208,7 +208,7 @@ LispObject name = getGenericFunctionName(); if (name != null) { - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); sb.append(getLispClass().getSymbol().writeToString()); sb.append(' '); sb.append(name.writeToString()); Modified: trunk/abcl/src/org/armedbear/lisp/StandardMethod.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardMethod.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StandardMethod.java Mon Feb 8 03:05:15 2010 @@ -155,7 +155,7 @@ ((StandardGenericFunction)genericFunction).getGenericFunctionName(); if (name != null) { - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); sb.append(getLispClass().getSymbol().writeToString()); sb.append(' '); sb.append(name.writeToString()); Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Mon Feb 8 03:05:15 2010 @@ -553,13 +553,13 @@ public LispObject readSymbol() { final Readtable rt = (Readtable) Symbol.CURRENT_READTABLE.symbolValue(LispThread.currentThread()); - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); _readToken(sb, rt); return new Symbol(sb.toString()); } public LispObject readSymbol(Readtable rt) { - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); _readToken(sb, rt); return new Symbol(sb.toString()); } @@ -784,7 +784,7 @@ if (n < 0) return error(new EndOfFile(this)); char c = (char) n; // ### BUG: Codepoint conversion - FastStringBuffer sb = new FastStringBuffer(c); + StringBuilder sb = new StringBuilder(String.valueOf(c)); while (true) { n = _readChar(); if (n < 0) @@ -887,7 +887,7 @@ if (obj instanceof Cons && obj.length() == 2) return Complex.getInstance(obj.car(), obj.cadr()); // Error. - FastStringBuffer sb = new FastStringBuffer("Invalid complex number format"); + StringBuilder sb = new StringBuilder("Invalid complex number format"); if (this instanceof FileStream) { Pathname p = ((FileStream)this).getPathname(); if (p != null) { @@ -914,7 +914,7 @@ if (obj instanceof Cons && obj.length() == 2) return Complex.getInstance(obj.car(), obj.cadr()); // Error. - FastStringBuffer sb = new FastStringBuffer("Invalid complex number format"); + StringBuilder sb = new StringBuilder("Invalid complex number format"); if (this instanceof FileStream) { Pathname p = ((FileStream)this).getPathname(); if (p != null) { @@ -934,7 +934,7 @@ } private String readMultipleEscape(Readtable rt) { - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); try { while (true) { int n = _readChar(); @@ -994,7 +994,7 @@ private final LispObject readToken(char c, Readtable rt) { - FastStringBuffer sb = new FastStringBuffer(c); + StringBuilder sb = new StringBuilder(String.valueOf(c)); final LispThread thread = LispThread.currentThread(); BitSet flags = _readToken(sb, rt); if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) @@ -1085,7 +1085,7 @@ return ((Package)Symbol._PACKAGE_.symbolValue(thread)).intern(new SimpleString(token)); } - private final BitSet _readToken(FastStringBuffer sb, Readtable rt) + private final BitSet _readToken(StringBuilder sb, Readtable rt) { BitSet flags = null; @@ -1198,7 +1198,7 @@ state = LOWER; } } - FastStringBuffer sb = new FastStringBuffer(limit); + StringBuilder sb = new StringBuilder(limit); for (int i = 0; i < limit; i++) { char c = s.charAt(i); if (flags != null && flags.get(i)) // Escaped. @@ -1311,7 +1311,7 @@ { if (length == 0) return null; - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); int i = 0; boolean maybe = false; char marker = 0; @@ -1373,7 +1373,7 @@ } public LispObject readRadix(int radix) { - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); final LispThread thread = LispThread.currentThread(); final Readtable rt = (Readtable) Symbol.CURRENT_READTABLE.symbolValue(thread); @@ -1402,7 +1402,7 @@ } public LispObject faslReadRadix(int radix) { - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); final LispThread thread = LispThread.currentThread(); final Readtable rt = FaslReadtable.getInstance(); boolean escaped = (_readToken(sb, rt) != null); @@ -1471,7 +1471,7 @@ { final LispThread thread = LispThread.currentThread(); - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); try { while (true) { int n = _readChar(); Modified: trunk/abcl/src/org/armedbear/lisp/StringFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StringFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StringFunctions.java Mon Feb 8 03:05:15 2010 @@ -584,7 +584,7 @@ return error(new TypeError("Invalid end position " + start + ".")); if (start > end) return error(new TypeError("Start (" + start + ") is greater than end (" + end + ").")); - FastStringBuffer sb = new FastStringBuffer(length); + StringBuilder sb = new StringBuilder(length); char[] array = s.getStringChars(); int i; for (i = 0; i < start; i++) @@ -619,7 +619,7 @@ return error(new TypeError("Invalid end position " + start + ".")); if (start > end) return error(new TypeError("Start (" + start + ") is greater than end (" + end + ").")); - FastStringBuffer sb = new FastStringBuffer(length); + StringBuilder sb = new StringBuilder(length); char[] array = s.getStringChars(); int i; for (i = 0; i < start; i++) @@ -655,7 +655,7 @@ return error(new TypeError("Invalid end position " + start + ".")); if (start > end) return error(new TypeError("Start (" + start + ") is greater than end (" + end + ").")); - FastStringBuffer sb = new FastStringBuffer(length); + StringBuilder sb = new StringBuilder(length); char[] array = s.getStringChars(); boolean lastCharWasAlphanumeric = false; int i; @@ -813,7 +813,7 @@ { final int n = Fixnum.getValue(size); if (n < 0 || n >= ARRAY_DIMENSION_MAX) { - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); sb.append("The size specified for this string ("); sb.append(n); sb.append(')'); Modified: trunk/abcl/src/org/armedbear/lisp/StructureObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StructureObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StructureObject.java Mon Feb 8 03:05:15 2010 @@ -377,7 +377,7 @@ private LispObject badIndex(int n) { - FastStringBuffer sb = new FastStringBuffer("Invalid slot index "); + StringBuilder sb = new StringBuilder("Invalid slot index "); sb.append(Fixnum.getInstance(n).writeToString()); sb.append(" for "); sb.append(writeToString()); @@ -431,7 +431,7 @@ int currentLevel = Fixnum.getValue(currentPrintLevel); if (currentLevel >= maxLevel && slots.length > 0) return "#"; - FastStringBuffer sb = new FastStringBuffer("#S("); + StringBuilder sb = new StringBuilder("#S("); sb.append(structureClass.getSymbol().writeToString()); if (currentLevel < maxLevel) { 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 Feb 8 03:05:15 2010 @@ -118,7 +118,7 @@ thread.bindSpecial(Symbol.PRINT_ESCAPE, NIL); try { - FastStringBuffer sb = new FastStringBuffer("The symbol "); + StringBuilder sb = new StringBuilder("The symbol "); sb.append(name.writeToString()); sb.append(" at #x"); sb.append(Integer.toHexString(System.identityHashCode(this)).toUpperCase()); @@ -257,7 +257,7 @@ return("#:".concat(n)); if (pkg == PACKAGE_KEYWORD) return ":".concat(n); - FastStringBuffer sb = new FastStringBuffer(((Package)pkg).getName()); + StringBuilder sb = new StringBuilder(((Package)pkg).getName()); if (((Package)pkg).findExternalSymbol(name) != null) sb.append(':'); else @@ -444,7 +444,7 @@ if (readtableCase != Keyword.UPCASE || printCase != Keyword.UPCASE) { - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); if (pkg == PACKAGE_KEYWORD) { sb.append(':'); @@ -572,7 +572,7 @@ packageName = invert(packageName); } } - FastStringBuffer sb = new FastStringBuffer(packageName); + StringBuilder sb = new StringBuilder(packageName); if (((Package)pkg).findExternalSymbol(name) != null && DOUBLE_COLON_PACKAGE_SEPARATORS.symbolValue(thread) == NIL) sb.append(':'); @@ -607,7 +607,7 @@ state = LOWER; } } - FastStringBuffer sb = new FastStringBuffer(limit); + StringBuilder sb = new StringBuilder(limit); for (int i = 0; i < limit; i++) { char c = s.charAt(i); @@ -695,7 +695,7 @@ private static final String multipleEscape(String s) { - FastStringBuffer sb = new FastStringBuffer("|"); + StringBuilder sb = new StringBuilder("|"); final int limit = s.length(); for (int i = 0; i < limit; i++) { @@ -713,7 +713,7 @@ if (readtableCase == Keyword.INVERT || readtableCase == Keyword.PRESERVE) return s; final int limit = s.length(); - FastStringBuffer sb = new FastStringBuffer(limit); + StringBuilder sb = new StringBuilder(limit); boolean lastCharWasAlphanumeric = false; for (int i = 0; i < limit; i++) { Modified: trunk/abcl/src/org/armedbear/lisp/Time.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Time.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Time.java Mon Feb 8 03:05:15 2010 @@ -62,7 +62,7 @@ Stream out = checkCharacterOutputStream(Symbol.TRACE_OUTPUT.symbolValue()); out.freshLine(); - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); sb.append(String.valueOf((float)realElapsed / 1000)); sb.append(" seconds real time"); sb.append(System.getProperty("line.separator")); Modified: trunk/abcl/src/org/armedbear/lisp/TypeError.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/TypeError.java (original) +++ trunk/abcl/src/org/armedbear/lisp/TypeError.java Mon Feb 8 03:05:15 2010 @@ -138,7 +138,7 @@ return s; final LispObject datum = getDatum(); final LispObject expectedType = getExpectedType(); - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); String name = datum != null ? datum.writeToString() : null; String type = null; if (expectedType != null) Modified: trunk/abcl/src/org/armedbear/lisp/UnboundSlot.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/UnboundSlot.java (original) +++ trunk/abcl/src/org/armedbear/lisp/UnboundSlot.java Mon Feb 8 03:05:15 2010 @@ -75,7 +75,7 @@ final SpecialBindingsMark mark = thread.markSpecialBindings(); thread.bindSpecial(Symbol.PRINT_ESCAPE, T); try { - FastStringBuffer sb = new FastStringBuffer("The slot "); + StringBuilder sb = new StringBuilder("The slot "); sb.append(getCellName().writeToString()); sb.append(" is unbound in the object "); sb.append(getInstance().writeToString()); Modified: trunk/abcl/src/org/armedbear/lisp/UndefinedFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/UndefinedFunction.java (original) +++ trunk/abcl/src/org/armedbear/lisp/UndefinedFunction.java Mon Feb 8 03:05:15 2010 @@ -72,7 +72,7 @@ @Override public String getMessage() { - FastStringBuffer sb = new FastStringBuffer("The function "); + StringBuilder sb = new StringBuilder("The function "); sb.append(getCellName().writeToString()); sb.append(" is undefined."); return sb.toString(); Modified: trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java (original) +++ trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java Mon Feb 8 03:05:15 2010 @@ -71,8 +71,8 @@ if(message != null) { return message; } - FastStringBuffer sb = - new FastStringBuffer("Wrong number of arguments"); + StringBuilder sb = + new StringBuilder("Wrong number of arguments"); LispObject lambdaName = operator.getLambdaName(); if (lambdaName != null && lambdaName != NIL) { sb.append(" for "); 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 Mon Feb 8 03:05:15 2010 @@ -537,14 +537,7 @@ (defun canonical-slot-name (canonical-slot) (getf canonical-slot :name)) -(defun ensure-class (name &rest all-keys - &key (metaclass 'standard-class) &allow-other-keys) - - ;; Don't pass METACLASS on to the initialization routines - ;; This only works because we *know* ABCL conses up new &rest lists - ;; every time; otherwise, modifying the argument list is discouraged by the spec - (remf all-keys :metaclass) - +(defun ensure-class (name &rest all-keys &allow-other-keys) ;; Check for duplicate slots. (let ((slots (getf all-keys :direct-slots))) (dolist (s1 slots) @@ -589,12 +582,8 @@ (apply #'std-after-initialization-for-classes old-class all-keys) old-class))) (t - (let ((class (apply (if (eq metaclass 'standard-class) - #'make-instance-standard-class - #'make-instance) - (or (when (symbolp metaclass) - (find-class metaclass)) - metaclass) + (let ((class (apply #'make-instance-standard-class + (find-class 'standard-class) :name name all-keys))) (%set-find-class name class) class))))) Modified: trunk/abcl/src/org/armedbear/lisp/delete_file.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/delete_file.java (original) +++ trunk/abcl/src/org/armedbear/lisp/delete_file.java Mon Feb 8 03:05:15 2010 @@ -77,7 +77,7 @@ Thread.yield(); } Pathname truename = new Pathname(file.getAbsolutePath()); - FastStringBuffer sb = new FastStringBuffer("Unable to delete "); + StringBuilder sb = new StringBuilder("Unable to delete "); sb.append(file.isDirectory() ? "directory " : "file "); sb.append(truename.writeToString()); sb.append('.'); Modified: trunk/abcl/src/org/armedbear/lisp/make_array.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/make_array.java (original) +++ trunk/abcl/src/org/armedbear/lisp/make_array.java Mon Feb 8 03:05:15 2010 @@ -126,7 +126,7 @@ final int size = dimv[0]; if (size < 0 || size >= ARRAY_DIMENSION_MAX) { - FastStringBuffer sb = new FastStringBuffer(); + StringBuilder sb = new StringBuilder(); sb.append("The size specified for this array ("); sb.append(size); sb.append(')'); From mevenson at common-lisp.net Mon Feb 8 08:13:44 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 08 Feb 2010 03:13:44 -0500 Subject: [armedbear-cvs] r12432 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Feb 8 03:13:42 2010 New Revision: 12432 Log: Revert to r12425 for clos.lisp (which is broken under ANSI tests). Undo inadvertent fix in last commit. 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 Mon Feb 8 03:13:42 2010 @@ -537,7 +537,14 @@ (defun canonical-slot-name (canonical-slot) (getf canonical-slot :name)) -(defun ensure-class (name &rest all-keys &allow-other-keys) +(defun ensure-class (name &rest all-keys + &key (metaclass 'standard-class) &allow-other-keys) + + ;; Don't pass METACLASS on to the initialization routines + ;; This only works because we *know* ABCL conses up new &rest lists + ;; every time; otherwise, modifying the argument list is discouraged by the spec + (remf all-keys :metaclass) + ;; Check for duplicate slots. (let ((slots (getf all-keys :direct-slots))) (dolist (s1 slots) @@ -582,8 +589,12 @@ (apply #'std-after-initialization-for-classes old-class all-keys) old-class))) (t - (let ((class (apply #'make-instance-standard-class - (find-class 'standard-class) + (let ((class (apply (if (eq metaclass 'standard-class) + #'make-instance-standard-class + #'make-instance) + (or (when (symbolp metaclass) + (find-class metaclass)) + metaclass) :name name all-keys))) (%set-find-class name class) class))))) From mevenson at common-lisp.net Mon Feb 8 12:59:38 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 08 Feb 2010 07:59:38 -0500 Subject: [armedbear-cvs] r12433 - trunk/abcl/doc/design/pathnames Message-ID: Author: mevenson Date: Mon Feb 8 07:59:35 2010 New Revision: 12433 Log: Update jar pathname design document with current implementation status. Modified: trunk/abcl/doc/design/pathnames/abcl-jar-url.text Modified: trunk/abcl/doc/design/pathnames/abcl-jar-url.text ============================================================================== --- trunk/abcl/doc/design/pathnames/abcl-jar-url.text (original) +++ trunk/abcl/doc/design/pathnames/abcl-jar-url.text Mon Feb 8 07:59:35 2010 @@ -3,11 +3,10 @@ Mark Evenson Created: 09 JAN 2010 -Modified: 24 JAN 2010 +Modified: 08 FEB 2010 Notes towards sketching an implementation of "jar:" references to be -contained in PATHNAMEs within ABCL - +contained in PATHNAMEs within ABCL. Goals ----- @@ -30,7 +29,7 @@ An entry in a ABCL FASL in a URL accessible JAR file #p"jar:jar:http://example.org/abcl.jar!/foo.abcl!/foo-1.cls" -3. MERGE-PATHNAMES working for JAR entries +3. MERGE-PATHNAMES working for JAR entries in the following use cases: (merge-pathnames "foo-1.cls" "jar:jar:file:baz.jar!/foo.abcl!/foo._") "jar:jar:file:baz.jar!/foo.abcl!/foo-1.cls" @@ -47,6 +46,20 @@ 6. References "jar:" for all strings that java.net.URL can resolve works. +7. Make jar pathnames work as a valid argument for OPEN. + +8. Enable the loading of ASDF systems packaged within jar files. + +Status +------ + +As of svn r12431, all the above goals have been implemented and tested +*except* for: + +5. DIRECTORY working within JAR files + +7. Make jar pathnames work as a valid argument for OPEN. + Implementation -------------- @@ -69,7 +82,7 @@ known as a DEVICE PATHNAME. * If the DEVICE is a String it must be a String that successfully - constructs a URL via the java.net.URL(String) constructor + references a URL via the java.net.URL(String) constructor * Only the first entry in the the DEVICE list may be a String. @@ -97,7 +110,7 @@ } -// UC1 -- JAR entry +// UC2 -- JAR entry pathname: { namestring: "jar:file:baz.jar!/foo.abcl" device: ( pathname: { @@ -216,44 +229,45 @@ } - -Problems --------- - -1. DEVICE PATHNAMES require the context within the nested PATHNAME - structure to be interpreted correctly. - -Result: Be careful when manipulating PATHNAMEs that refer to JARs - - History ------- -In the use of PATHNAMEs linked by the DEVICE field, we found the problem -that UNC path support uses the DEVICE field - -Result: JARs located on UNC mounts can't be referenced. via '\\'. +Previously, ABCL did have some support for jar pathnames. This support +used the convention that the if the device field was itself a +pathname, the device pathname contained the location of the jar. + +In the analysis of the desire to treat jar pathnames as valid +locations for LOAD, we determined that we needed a "double" pathname +so we could refer to the components of a packed FASL in jar. At first +we thought we could support such a syntax by having the device +pathname's device refer to the inner jar. But with in this use of +PATHNAMEs linked by the DEVICE field, we found the problem that UNC +path support uses the DEVICE field so JARs located on UNC mounts can't +be referenced. via '\\'. i.e. jar:jar:file:\\server\share\a\b\foo.jar!/this\that!/foo.java -would not have +would not have a valid representation. -Solution: Instead of having DEVICE point to a PATHNAME, have DEVICE -be a list of PATHNAMES +So instead of having DEVICE point to a PATHNAME, we decided that the +DEVICE shall be a list of PATHNAMES, so we would have: pathname: { namestring: "jar:jar:file:\\server\share\foo.jar!/foo.abcl!/" - device: ( pathname: { - name: "foo" - type: "abcl" - } + device: ( pathname: { host: "server" device: "share" name: "foo" type: "jar" } + pathname: { + name: "foo" + type: "abcl" + } } -Which order for the list? Outermost first or last? Outermost first. +Although there is a fair amount of special logic inside Pathname.java +itself in the resulting implementation, the logic in Load.java seems +to have been considerably simplified. From mevenson at common-lisp.net Mon Feb 8 18:01:06 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 08 Feb 2010 13:01:06 -0500 Subject: [armedbear-cvs] r12434 - trunk/abcl Message-ID: Author: mevenson Date: Mon Feb 8 13:01:03 2010 New Revision: 12434 Log: Revert r12430 because it fails to signal errors in a meaningful manner. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Mon Feb 8 13:01:03 2010 @@ -220,19 +220,43 @@ - - + + + + (compile-system :zip nil :quit t + :output-path "${toString:abcl.lisp.output.path}${file.separator}") + + + + + + + + + + + + + + + Finished recording test output in ${abcl.test.log.file}. - + Author: mevenson Date: Tue Feb 9 10:42:58 2010 New Revision: 12435 Log: Turn off all caching of JAR entries as it inhibited reloading FASLs. The java.net.JarURLConnection implementation *never* invalidates its cache even for files on the local filesystem, making it highly unsuitable to represent FASL sources. One can create a custom protocol handler, but in the manner oh-so-typical of Java, we cannot use the default implementation so a sizable amount of coding lies ahead. For the time being, we just disable caching. 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 Tue Feb 9 10:42:58 2010 @@ -1746,7 +1746,8 @@ return null; } JarURLConnection jarURLConnection = (JarURLConnection) connection; - + // XXX implement custom protocol handler that actual does the necessary caching + connection.setUseCaches(false); JarFile result; try { result = jarURLConnection.getJarFile(); From vvoutilainen at common-lisp.net Tue Feb 9 20:45:55 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Tue, 09 Feb 2010 15:45:55 -0500 Subject: [armedbear-cvs] r12436 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Tue Feb 9 15:45:52 2010 New Revision: 12436 Log: Fix describe formatting, there was a missing newline. Problem reported by Blake McBride. Modified: trunk/abcl/src/org/armedbear/lisp/describe.lisp Modified: trunk/abcl/src/org/armedbear/lisp/describe.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/describe.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/describe.lisp Tue Feb 9 15:45:52 2010 @@ -139,11 +139,13 @@ (dolist (slotd (nreverse instance-slotds)) (describe-slot (%slot-definition-name slotd)))) + (format stream "~%") (when class-slotds (format stream "The following slots have :CLASS allocation:~%") (dolist (slotd (nreverse class-slotds)) (describe-slot - (%slot-definition-name slotd)))))) + (%slot-definition-name slotd))) + (format stream "~%")))) (values)) (defmethod describe-object ((object java:java-object) stream) From ehuelsmann at common-lisp.net Tue Feb 9 21:53:14 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 09 Feb 2010 16:53:14 -0500 Subject: [armedbear-cvs] r12437 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Feb 9 16:53:09 2010 New Revision: 12437 Log: CHAR-CODE-LIMIT is the upper *exclusive* limit. Found by: Paul Griffioen 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 Tue Feb 9 16:53:09 2010 @@ -2392,7 +2392,7 @@ public static final int CHAR_MAX = Character.MAX_VALUE; static { - Symbol.CHAR_CODE_LIMIT.initializeConstant(Fixnum.getInstance(CHAR_MAX)); + Symbol.CHAR_CODE_LIMIT.initializeConstant(Fixnum.getInstance(CHAR_MAX + 1)); } static From mevenson at common-lisp.net Wed Feb 10 10:41:26 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 10 Feb 2010 05:41:26 -0500 Subject: [armedbear-cvs] r12438 - trunk/abcl Message-ID: Author: mevenson Date: Wed Feb 10 05:41:24 2010 New Revision: 12438 Log: Implementation of Lisp build without intermediate files. It is still the case that if anything loaded by 'boot.lisp' causes an error, the 'abcl.compile.lisp' task does not properly signal an error to the Ant build process. But this is no different from the previous behavior, so we adopt this as the conceptually simpler approach to writing Ant tasks (and the one that doesn't litter the filesystem with intermediate build files when the compilation process is being debugged). Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Wed Feb 10 05:41:24 2010 @@ -220,43 +220,25 @@ + - - - - - - (compile-system :zip nil :quit t - :output-path "${toString:abcl.lisp.output.path}${file.separator}") - - - - - - - - - - - +Compiling Lisp system +from ${abcl.home.dir} +to ${abcl.lisp.output} + - - + + - - Finished recording test output in ${abcl.test.log.file}. - + Author: mevenson Date: Wed Feb 10 11:13:29 2010 New Revision: 12439 Log: Remove duplication of java options. Modified: trunk/abcl/abcl.bat.in Modified: trunk/abcl/abcl.bat.in ============================================================================== --- trunk/abcl/abcl.bat.in (original) +++ trunk/abcl/abcl.bat.in Wed Feb 10 11:13:29 2010 @@ -1 +1 @@ -@"@JAVA@" @ABCL_JAVA_OPTIONS@ @ABCL_JAVA_OPTIONS@ -cp "@ABCL_CLASSPATH@" org.armedbear.lisp.Main %1 %2 %3 %4 %5 %6 %7 %8 %9 +@"@JAVA@" @ABCL_JAVA_OPTIONS@ -cp "@ABCL_CLASSPATH@" org.armedbear.lisp.Main %1 %2 %3 %4 %5 %6 %7 %8 %9 From mevenson at common-lisp.net Wed Feb 10 16:14:23 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 10 Feb 2010 11:14:23 -0500 Subject: [armedbear-cvs] r12440 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Feb 10 11:14:22 2010 New Revision: 12440 Log: Documentation updates and conversion to stack trace friendly Primitive declarations. Modified: trunk/abcl/src/org/armedbear/lisp/Extensions.java Modified: trunk/abcl/src/org/armedbear/lisp/Extensions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Extensions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Extensions.java Wed Feb 10 11:14:22 2010 @@ -46,232 +46,264 @@ list(intern("DEFAULT-ED-FUNCTION", PACKAGE_SYS))); // ### truly-the value-type form => result* - private static final SpecialOperator TRULY_THE = - new SpecialOperator("truly-the", PACKAGE_EXT, true, "type value") + private static final SpecialOperator TRULY_THE = new truly_the(); + private static class truly_the extends SpecialOperator { + truly_the() { + super("truly-the", PACKAGE_EXT, true, "type value"); + } + @Override + public LispObject execute(LispObject args, Environment env) { - @Override - public LispObject execute(LispObject args, Environment env) - - { - if (args.length() != 2) - return error(new WrongNumberOfArgumentsException(this)); - return eval(args.cadr(), env, LispThread.currentThread()); - } - }; + if (args.length() != 2) + return error(new WrongNumberOfArgumentsException(this)); + return eval(args.cadr(), env, LispThread.currentThread()); + } + } // ### neq - private static final Primitive NEQ = - new Primitive(Symbol.NEQ, "obj1 obj2") + private static final Primitive NEQ = new neq(); + private static class neq extends Primitive + { + neq() + { + super(Symbol.NEQ, "obj1 obj2"); + } + @Override + public LispObject execute(LispObject first, LispObject second) { - @Override - public LispObject execute(LispObject first, LispObject second) - - { return first != second ? T : NIL; - } - }; + } + } // ### memq item list => tail - private static final Primitive MEMQ = - new Primitive(Symbol.MEMQ, "item list") + private static final Primitive MEMQ = new memq(); + private static class memq extends Primitive + { + memq() { - @Override - public LispObject execute(LispObject item, LispObject list) - - { - while (list instanceof Cons) - { - if (item == ((Cons)list).car) - return list; - list = ((Cons)list).cdr; - } - if (list != NIL) - type_error(list, Symbol.LIST); - return NIL; - } - }; + super(Symbol.MEMQ, "item list"); + } + @Override + public LispObject execute(LispObject item, LispObject list) + { + while (list instanceof Cons) + { + if (item == ((Cons)list).car) + return list; + list = ((Cons)list).cdr; + } + if (list != NIL) + type_error(list, Symbol.LIST); + return NIL; + } + } // ### memql item list => tail - private static final Primitive MEMQL = - new Primitive(Symbol.MEMQL, "item list") + private static final Primitive MEMQL = new memql(); + private static class memql extends Primitive + { + memql() { + super(Symbol.MEMQL, "item list"); + } + @Override + public LispObject execute(LispObject item, LispObject list) { - @Override - public LispObject execute(LispObject item, LispObject list) - - { - while (list instanceof Cons) - { - if (item.eql(((Cons)list).car)) - return list; - list = ((Cons)list).cdr; - } - if (list != NIL) - type_error(list, Symbol.LIST); - return NIL; - } - }; + while (list instanceof Cons) + { + if (item.eql(((Cons)list).car)) + return list; + list = ((Cons)list).cdr; + } + if (list != NIL) + type_error(list, Symbol.LIST); + return NIL; + } + } // ### adjoin-eql item list => new-list - private static final Primitive ADJOIN_EQL = - new Primitive(Symbol.ADJOIN_EQL, "item list") + private static final Primitive ADJOIN_EQL = new adjoin_eql(); + private static class adjoin_eql extends Primitive { + adjoin_eql() { + super(Symbol.ADJOIN_EQL, "item list"); + } + @Override + public LispObject execute(LispObject item, LispObject list) { - @Override - public LispObject execute(LispObject item, LispObject list) - - { - return memql(item, list) ? list : new Cons(item, list); - } - }; + return memql(item, list) ? list : new Cons(item, list); + } + } // ### special-variable-p - private static final Primitive SPECIAL_VARIABLE_P = - new Primitive("special-variable-p", PACKAGE_EXT, true) + private static final Primitive SPECIAL_VARIABLE_P = new special_variable_p(); + private static class special_variable_p extends Primitive { + special_variable_p() { + super("special-variable-p", PACKAGE_EXT, true); + } + @Override + public LispObject execute(LispObject arg) { - @Override - public LispObject execute(LispObject arg) - { - return arg.isSpecialVariable() ? T : NIL; - } - }; - - // ### source - private static final Primitive SOURCE = - new Primitive("source", PACKAGE_EXT, true) - { - @Override - public LispObject execute(LispObject arg) - { - return get(arg, Symbol._SOURCE, NIL); - } - }; - - // ### source-file-position - private static final Primitive SOURCE_FILE_POSITION = - new Primitive("source-file-position", PACKAGE_EXT, true) - { - @Override - public LispObject execute(LispObject arg) - { - LispObject obj = get(arg, Symbol._SOURCE, NIL); - if (obj instanceof Cons) - return obj.cdr(); - return NIL; - } - }; + return arg.isSpecialVariable() ? T : NIL; + } + } + + // ### source symbol + private static final Primitive SOURCE = new source(); + private static class source extends Primitive { + source() { + super("source", PACKAGE_EXT, true); + } + @Override + public LispObject execute(LispObject arg) + { + return get(arg, Symbol._SOURCE, NIL); + } + } + + // ### source-file-position symbol + private static final Primitive SOURCE_FILE_POSITION = new source_file_position(); + private static class source_file_position extends Primitive { + source_file_position() { + super("source-file-position", PACKAGE_EXT, true); + } + @Override + public LispObject execute(LispObject arg) + { + LispObject obj = get(arg, Symbol._SOURCE, NIL); + if (obj instanceof Cons) + return obj.cdr(); + return NIL; + } + } // ### source-pathname - public static final Primitive SOURCE_PATHNAME = - new Primitive("source-pathname", PACKAGE_EXT, true) + public static final Primitive SOURCE_PATHNAME = new source_pathname(); + private static class source_pathname extends Primitive { + source_pathname() { + super("source-pathname", PACKAGE_EXT, true); + } + @Override + public LispObject execute(LispObject arg) { - @Override - public LispObject execute(LispObject arg) - { - LispObject obj = get(arg, Symbol._SOURCE, NIL); - if (obj instanceof Cons) - return obj.car(); - return obj; - } - }; + LispObject obj = get(arg, Symbol._SOURCE, NIL); + if (obj instanceof Cons) + return obj.car(); + return obj; + } + } // ### exit - private static final Primitive EXIT = - new Primitive("exit", PACKAGE_EXT, true, "&key status") + private static final Primitive EXIT = new exit(); + private static class exit extends Primitive { + exit() { + super("exit", PACKAGE_EXT, true, "&key status"); + } + @Override + public LispObject execute() + { + exit(0); + return LispThread.currentThread().nothing(); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { - @Override - public LispObject execute() - { - exit(0); - return LispThread.currentThread().nothing(); - } - @Override - public LispObject execute(LispObject first, LispObject second) - - { - int status = 0; - if (first == Keyword.STATUS) - { - if (second instanceof Fixnum) - status = ((Fixnum)second).value; - } - exit(status); - return LispThread.currentThread().nothing(); - } - }; + int status = 0; + if (first == Keyword.STATUS) + { + if (second instanceof Fixnum) + status = ((Fixnum)second).value; + } + exit(status); + return LispThread.currentThread().nothing(); + } + } // ### quit - private static final Primitive QUIT = - new Primitive("quit", PACKAGE_EXT, true, "&key status") + private static final Primitive QUIT = new quit(); + private static class quit extends Primitive { + quit() { + super("quit", PACKAGE_EXT, true, "&key status"); + } + @Override + public LispObject execute() { - @Override - public LispObject execute() - { - exit(0); - return LispThread.currentThread().nothing(); - } - @Override - public LispObject execute(LispObject first, LispObject second) - - { - int status = 0; - if (first == Keyword.STATUS) - { - if (second instanceof Fixnum) - status = ((Fixnum)second).value; - } - exit(status); - return LispThread.currentThread().nothing(); - } - }; + exit(0); + return LispThread.currentThread().nothing(); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + int status = 0; + if (first == Keyword.STATUS) + { + if (second instanceof Fixnum) + status = ((Fixnum)second).value; + } + exit(status); + return LispThread.currentThread().nothing(); + } + } // ### dump-java-stack - private static final Primitive DUMP_JAVA_STACK = - new Primitive("dump-java-stack", PACKAGE_EXT, true) + private static final Primitive DUMP_JAVA_STACK = new dump_java_stack(); + private static class dump_java_stack extends Primitive { + dump_java_stack() { + super("dump-java-stack", PACKAGE_EXT, true); + } + @Override + public LispObject execute() { - @Override - public LispObject execute() - { - Thread.dumpStack(); - return LispThread.currentThread().nothing(); - } - }; - - // ### make-temp-file => namestring - private static final Primitive MAKE_TEMP_FILE = - new Primitive("make-temp-file", PACKAGE_EXT, true, "") - { - @Override - public LispObject execute() - { - try - { - File file = File.createTempFile("abcl", null, null); - if (file != null) - return new Pathname(file.getPath()); - } - catch (IOException e) - { - Debug.trace(e); - } - return NIL; - } - }; + Thread.dumpStack(); + return LispThread.currentThread().nothing(); + } + } + + // ### make-temp-file => pathname + private static final Primitive MAKE_TEMP_FILE = new make_temp_file(); + private static class make_temp_file extends Primitive { + make_temp_file() { + super("make-temp-file", PACKAGE_EXT, true, ""); + } + @Override + public LispObject execute() + { + try + { + File file = File.createTempFile("abcl", null, null); + if (file != null) + return new Pathname(file.getPath()); + } + catch (IOException e) + { + Debug.trace(e); + } + return NIL; + } + } // ### interrupt-lisp - private static final Primitive INTERRUPT_LISP = - new Primitive("interrupt-lisp", PACKAGE_EXT, true, "") + private static final Primitive INTERRUPT_LISP = new interrupt_lisp(); + private static class interrupt_lisp extends Primitive { + interrupt_lisp() { + super("interrupt-lisp", PACKAGE_EXT, true, ""); + } + @Override + public LispObject execute() { - @Override - public LispObject execute() - { - setInterrupted(true); - return T; - } - }; - - // ### getenv - private static final Primitive GETENV = - new Primitive("getenv", PACKAGE_EXT, true) + setInterrupted(true); + return T; + } + } + + // ### getenv variable => string + private static final Primitive GETENV = new getenv(); + private static class getenv extends Primitive { + getenv() + { + super("getenv", PACKAGE_EXT, true, "variable", + "Return the value of the environment VARIABLE if it exists, otherwise return NIL."); + } @Override public LispObject execute(LispObject arg) { @@ -286,5 +318,5 @@ else return NIL; } - }; + } } From mevenson at common-lisp.net Wed Feb 10 16:22:21 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 10 Feb 2010 11:22:21 -0500 Subject: [armedbear-cvs] r12441 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Feb 10 11:22:21 2010 New Revision: 12441 Log: Return of the ZipCache now using last modified time. Treat jars as zips in ZipCache which maintains an cache of all ZipFiles accessed via Pathname jars (which should be the entire system as Load now uses Pathname). ZipCache currently does not invalidate entries for any non-file resources due to deficiencies in the JVM that need to be corrected on a per-protocol basis. For instance, for HTTP we need an implementation that uses HTTP HEAD requests to get the Last-Modified header as opposed to re-fetching the entire resource as the JVM URLConnection does. SYS:REMOVE-ZIP-CACHE-ENTRY implements a way to invalidate ZipCache entries from Lisp. Used it in COMPILE-FILE to successfully recompile FASLs under Windows. Rewrite remaining Pathname Primtives in the informative stack trace style. Implement Debug.warn() which can be shut off with SYS::*DEBUG-WARN*. The intent here is to have a way to warn about Java side events which having potentially worrying side-effects during development which is by default not visible to end users (although it can be). Removed unused EXT:LAST-MODIFIED in favor of existing ANSI FILE-WRITE-DATE. Added: trunk/abcl/src/org/armedbear/lisp/ZipCache.java Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/Debug.java trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/src/org/armedbear/lisp/Utilities.java trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Wed Feb 10 11:22:21 2010 @@ -644,6 +644,7 @@ autoload(PACKAGE_SYS, "psxhash", "HashTableFunctions"); autoload(PACKAGE_SYS, "puthash", "HashTableFunctions"); autoload(PACKAGE_SYS, "puthash", "HashTableFunctions"); + autoload(PACKAGE_SYS, "remove-zip-cache-entry", "ZipCache"); autoload(PACKAGE_SYS, "set-function-info-value", "function_info"); autoload(PACKAGE_SYS, "set-generic-function-argument-precedence-order","StandardGenericFunction", true); autoload(PACKAGE_SYS, "set-generic-function-classes-to-emf-table","StandardGenericFunction", true); Modified: trunk/abcl/src/org/armedbear/lisp/Debug.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Debug.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Debug.java Wed Feb 10 11:22:21 2010 @@ -33,8 +33,11 @@ package org.armedbear.lisp; +import static org.armedbear.lisp.Lisp.*; + public final class Debug { + public static final void assertTrue(boolean b) { if (!b) { @@ -60,4 +63,21 @@ { t.printStackTrace(); } + + public static final Symbol _DEBUG_WARN_ + = exportSpecial("*DEBUG-WARN*", PACKAGE_SYS, NIL); + + public static void setDebugWarnings(boolean flag) { + if (flag) { + _DEBUG_WARN_.setSymbolValue(T); + } else { + _DEBUG_WARN_.setSymbolValue(NIL); + } + } + + public static final void warn(String s) { + if (_DEBUG_WARN_.getSymbolValue() != null) { + trace(s); + } + } } Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Wed Feb 10 11:22:21 2010 @@ -43,11 +43,14 @@ import java.net.URL; import java.net.URLConnection; import java.net.URLDecoder; +import java.util.HashMap; import java.util.StringTokenizer; import java.util.jar.JarEntry; import java.util.jar.JarFile; import java.util.zip.ZipEntry; +import java.util.zip.ZipFile; import java.util.zip.ZipInputStream; +import java.util.zip.ZipException; public class Pathname extends LispObject { @@ -1640,7 +1643,7 @@ // 2. JAR in JAR // 3. JAR with Entry // 4. JAR in JAR with Entry - JarFile jarFile = getJarFile(jars.car()); + ZipFile jarFile = ZipCache.get(jars.car()); String entryPath = pathname.asEntryPath(); if (jarFile != null) { if (jars.cdr() instanceof Cons) { @@ -1707,54 +1710,18 @@ return result; } - /** Make a JarURL from a generic URL reference. */ - private static URL makeJarURL(String url) { - String jarURL = "jar:" + url + "!/"; + protected static URL makeURL(LispObject device) { URL result = null; try { - result = new URL(jarURL); - } catch (MalformedURLException ex) { - // XXX - Debug.trace("Could not form jar URL from " - + "'" + jarURL + "'" - + " because " + ex); - } - return result; - } - - private static JarFile getJarFile(LispObject device) { - URL url = null; if (device instanceof SimpleString) { - url = makeJarURL(((SimpleString) device).getStringValue()); + result = new URL(((SimpleString)device).getStringValue()); } else { - url = makeJarURL((Pathname) device); - } - if (url == null) { - return null; - } - URLConnection connection; - try { - connection = url.openConnection(); - } catch (IOException ex) { - Debug.trace("Failed to open " - + "'" + url + "'"); - return null; + // XXX ensure that we have cannonical path. + Pathname p = (Pathname)device; + result = new URL("file:" + p.getNamestring()); } - if (!(connection instanceof JarURLConnection)) { - // XXX - Debug.trace("Could not get a URLConnection from " + url); - return null; - } - JarURLConnection jarURLConnection = (JarURLConnection) connection; - // XXX implement custom protocol handler that actual does the necessary caching - connection.setUseCaches(false); - JarFile result; - try { - result = jarURLConnection.getJarFile(); - } catch (IOException ex) { - Debug.trace("Could not get a JarURLConnection from " - + "'" + jarURLConnection + "'"); - return null; + } catch (MalformedURLException e) { + Debug.trace("Could not form URL from " + device); } return result; } @@ -1765,7 +1732,7 @@ String entryPath = asEntryPath(); // XXX We only return the bytes of an entry in a JAR Debug.assertTrue(entryPath != null); - JarFile jarFile = Pathname.getJarFile(device.car()); + ZipFile jarFile = ZipCache.get(device.car()); Debug.assertTrue(jarFile != null); // Is this a JAR within a JAR? if (device.cdr() instanceof Cons) { @@ -1802,22 +1769,6 @@ return result; } - // ### last-modified pathname => time-in-milliseconds - public static final Primitive LAST_MODIFIED - = new Primitive("LAST-MODIFIED", PACKAGE_EXT, true, "pathname", - "If PATHNAME exists, returns the last modified time in miliseconds since the UNIX epoch.") - { - @Override - public LispObject execute(LispObject arg) { - final Pathname p = coerceToPathname(arg); - if (p.isWild()) { - error(new FileError("Bad place for a wild pathname.", p)); - } - long time = p.getLastModified(); - return LispInteger.getInstance(time); - } - }; - /** @return Time in milliseconds since the UNIX epoch at which the * resource was last modified, or 0 if the time is unknown. */ @@ -1839,23 +1790,26 @@ LispObject o = d.car(); if (o instanceof SimpleString) { // 0. JAR from URL - URL u = makeJarURL(o.getStringValue()); - URLConnection c = null; - try { - c = u.openConnection(); - } catch(IOException e) { - Debug.trace("Failed to open Connection for URL " - + "'" + u + "'"); - return 0; - } - c.getLastModified(); + // URL u = makeJarURL(o.getStringValue()); + // XXX unimplemented + Debug.assertTrue(false); + // URLConnection c = null; + // try { + // c = u.openConnection(); + // } catch(IOException e) { + // Debug.trace("Failed to open Connection for URL " + // + "'" + u + "'"); + // return 0; + // } + // c.getLastModified(); } else { // 1. JAR return ((Pathname)o).getLastModified(); } } else { // 3. Entry in JAR - final JarEntry entry = getJarFile(device.car()).getJarEntry(entryPath); + final ZipEntry entry + = ZipCache.get(device.car()).getEntry(entryPath); if (entry == null) { return 0; } @@ -1866,11 +1820,11 @@ return time; } } else { - JarFile outerJar = getJarFile(d.car()); + ZipFile outerJar = ZipCache.get(d.car()); if (entryPath.length() == 0) { // 4. JAR in JAR String jarPath = ((Pathname)d.cdr()).asEntryPath(); - final JarEntry entry = outerJar.getJarEntry(jarPath); + final ZipEntry entry = outerJar.getEntry(jarPath); final long time = entry.getTime(); if (time == -1) { return 0; @@ -1894,96 +1848,107 @@ return 0; } - // ### mkdir - private static final Primitive MKDIR = - new Primitive("mkdir", PACKAGE_SYS, false) { + // ### mkdir pathname + private static final Primitive MKDIR = new mkdir(); + private static class mkdir extends Primitive { + mkdir() { + super("mkdir", PACKAGE_SYS, false, "pathname"); + } - @Override - public LispObject execute(LispObject arg) { - final Pathname pathname = coerceToPathname(arg); - if (pathname.isWild()) { - error(new FileError("Bad place for a wild pathname.", pathname)); - } - Pathname defaultedPathname = + @Override + public LispObject execute(LispObject arg) { + final Pathname pathname = coerceToPathname(arg); + if (pathname.isWild()) { + error(new FileError("Bad place for a wild pathname.", pathname)); + } + Pathname defaultedPathname = mergePathnames(pathname, - coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue()), - NIL); - File file = Utilities.getFile(defaultedPathname); - return file.mkdir() ? T : NIL; - } - }; + coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue()), + NIL); + File file = Utilities.getFile(defaultedPathname); + return file.mkdir() ? T : NIL; + } + } + // ### rename-file filespec new-name => defaulted-new-name, old-truename, new-truename - public static final Primitive RENAME_FILE = - new Primitive("rename-file", "filespec new-name") { + private static final Primitive RENAME_FILE = new rename_file(); + private static class rename_file extends Primitive { + rename_file() { + super("rename-file", "filespec new-name"); + } + @Override + public LispObject execute(LispObject first, LispObject second) { + final Pathname original = (Pathname) truename(first, true); + final String originalNamestring = original.getNamestring(); + Pathname newName = coerceToPathname(second); + if (newName.isWild()) { + error(new FileError("Bad place for a wild pathname.", newName)); + } + newName = mergePathnames(newName, original, NIL); + final String newNamestring; + if (newName instanceof LogicalPathname) { + newNamestring = LogicalPathname.translateLogicalPathname((LogicalPathname) newName).getNamestring(); + } else { + newNamestring = newName.getNamestring(); + } + if (originalNamestring != null && newNamestring != null) { + final File source = new File(originalNamestring); + final File destination = new File(newNamestring); + if (Utilities.isPlatformWindows) { + if (destination.isFile()) { + destination.delete(); + } + } + if (source.renameTo(destination)) { // Success! + return LispThread.currentThread().setValues(newName, original, + truename(newName, true)); + } + } + return error(new FileError("Unable to rename " + + original.writeToString() + + " to " + newName.writeToString() + + ".")); + } + } - @Override - public LispObject execute(LispObject first, LispObject second) { - final Pathname original = (Pathname) truename(first, true); - final String originalNamestring = original.getNamestring(); - Pathname newName = coerceToPathname(second); - if (newName.isWild()) { - error(new FileError("Bad place for a wild pathname.", newName)); - } - newName = mergePathnames(newName, original, NIL); - final String newNamestring; - if (newName instanceof LogicalPathname) { - newNamestring = LogicalPathname.translateLogicalPathname((LogicalPathname) newName).getNamestring(); - } else { - newNamestring = newName.getNamestring(); - } - if (originalNamestring != null && newNamestring != null) { - final File source = new File(originalNamestring); - final File destination = new File(newNamestring); - if (Utilities.isPlatformWindows) { - if (destination.isFile()) { - destination.delete(); - } - } - if (source.renameTo(destination)) // Success! - { - return LispThread.currentThread().setValues(newName, original, - truename(newName, true)); - } - } - return error(new FileError("Unable to rename " - + original.writeToString() - + " to " + newName.writeToString() - + ".")); - } - }; // ### file-namestring pathname => namestring - private static final Primitive FILE_NAMESTRING = - new Primitive("file-namestring", "pathname") { + private static final Primitive FILE_NAMESTRING = new file_namestring(); + private static class file_namestring extends Primitive { + file_namestring() { + super("file-namestring", "pathname"); + } + @Override + public LispObject execute(LispObject arg) { + Pathname p = coerceToPathname(arg); + StringBuilder sb = new StringBuilder(); + if (p.name instanceof AbstractString) { + sb.append(p.name.getStringValue()); + } else if (p.name == Keyword.WILD) { + sb.append('*'); + } else { + return NIL; + } + if (p.type instanceof AbstractString) { + sb.append('.'); + sb.append(p.type.getStringValue()); + } else if (p.type == Keyword.WILD) { + sb.append(".*"); + } + return new SimpleString(sb); + } + } - @Override - public LispObject execute(LispObject arg) { - Pathname p = coerceToPathname(arg); - StringBuilder sb = new StringBuilder(); - if (p.name instanceof AbstractString) { - sb.append(p.name.getStringValue()); - } else if (p.name == Keyword.WILD) { - sb.append('*'); - } else { - return NIL; - } - if (p.type instanceof AbstractString) { - sb.append('.'); - sb.append(p.type.getStringValue()); - } else if (p.type == Keyword.WILD) { - sb.append(".*"); - } - return new SimpleString(sb); - } - }; // ### host-namestring pathname => namestring - private static final Primitive HOST_NAMESTRING = - new Primitive("host-namestring", "pathname") { - - @Override - public LispObject execute(LispObject arg) { - return coerceToPathname(arg).host; - } - }; + private static final Primitive HOST_NAMESTRING = new host_namestring(); + private static class host_namestring extends Primitive { + host_namestring() { + super("host-namestring", "pathname"); + } + @Override + public LispObject execute(LispObject arg) { + return coerceToPathname(arg).host; + } + } public String toString() { return getNamestring(); Modified: trunk/abcl/src/org/armedbear/lisp/Utilities.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Utilities.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Utilities.java Wed Feb 10 11:22:21 2010 @@ -229,7 +229,7 @@ } } - static InputStream getInputStream(JarFile jarFile, Pathname inner) { + static InputStream getInputStream(ZipFile jarFile, Pathname inner) { String entryPath = inner.asEntryPath(); ZipEntry entry = jarFile.getEntry(entryPath); if (entry == null) { Added: trunk/abcl/src/org/armedbear/lisp/ZipCache.java ============================================================================== --- (empty file) +++ trunk/abcl/src/org/armedbear/lisp/ZipCache.java Wed Feb 10 11:22:21 2010 @@ -0,0 +1,187 @@ +/* + * ZipCache.java + * + * Copyright (C) 2003-2007 Peter Graves + * $Id: Pathname.java 12435 2010-02-09 15:42:58Z mevenson $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ +package org.armedbear.lisp; + + +import static org.armedbear.lisp.Lisp.*; + +import java.io.File; +import java.io.IOException; +import java.net.JarURLConnection; +import java.net.MalformedURLException; +import java.net.URL; +import java.net.URLConnection; +import java.util.HashMap; +import java.util.zip.ZipException; +import java.util.zip.ZipFile; + +/** + * A cache for all zip/jar file accesses by URL that uses the last + * modified time of the cached resource. + */ +public class ZipCache { + static class Entry { + long lastModified; + ZipFile file; + } + + static HashMap zipCache = new HashMap(); + + public static ZipFile get(LispObject arg) { + return get(Pathname.makeURL(arg)); + } + + public static ZipFile get(URL url) { + Entry entry = zipCache.get(url); + if (entry != null) { + if (url.getProtocol().equals("file")) { + File f = new File(url.getPath()); + long current = f.lastModified(); + if (current > entry.lastModified) { + try { + entry.file.close(); + entry.file = new ZipFile(f); + entry.lastModified = current; + } catch (IOException e) { + Debug.trace(e.toString()); // XXX + } + } + } else { + // Unfortunately, the Apple JDK under OS X doesn't do + // HTTP HEAD requests, instead refetching the entire + // resource, so the following code is a waste. I assume + // this is the case in all Sun-dervied JVMs. We'll have + // to implement a custom HTTP lastModified checker. + + // URLConnection connection; + // try { + // connection = url.openConnection(); + // } catch (IOException ex) { + // Debug.trace("Failed to open " + // + "'" + url + "'"); + // return null; + // } + // long current = connection.getLastModified(); + // if (current > entry.lastModified) { + // try { + // entry.file.close(); + // } catch (IOException ex) {} + // entry = fetchURL(url, false); + // } + } + } else { + if (url.getProtocol().equals("file")) { + entry = new Entry(); + File f = new File(url.getPath()); + entry.lastModified = f.lastModified(); + try { + entry.file = new ZipFile(f); + } catch (ZipException e) { + Debug.trace(e); // XXX + return null; + } catch (IOException e) { + Debug.trace(e); // XXX + return null; + } + } else { + entry = fetchURL(url, true); + } + zipCache.put(url, entry); + } + return entry.file; + } + + static private Entry fetchURL(URL url, boolean cached) { + Entry result = new Entry(); + URL jarURL = null; + try { + jarURL = new URL("jar:" + url + "!/"); + } catch (MalformedURLException e) { + Debug.trace(e); + Debug.assertTrue(false); // XXX + } + URLConnection connection; + try { + connection = jarURL.openConnection(); + } catch (IOException ex) { + Debug.trace("Failed to open " + + "'" + jarURL + "'"); + return null; + } + if (!(connection instanceof JarURLConnection)) { + // XXX + Debug.trace("Could not get a URLConnection from " + jarURL); + return null; + } + JarURLConnection jarURLConnection = (JarURLConnection) connection; + jarURLConnection.setUseCaches(cached); + try { + result.file = jarURLConnection.getJarFile(); + } catch (IOException e) { + Debug.trace(e); + Debug.assertTrue(false); // XXX + } + result.lastModified = jarURLConnection.getLastModified(); + return result; + } + + + + // ## remove-zip-cache-entry pathname => boolean + private static final Primitive REMOVE_ZIP_CACHE_ENTRY = new remove_zip_cache_entry(); + private static class remove_zip_cache_entry extends Primitive { + remove_zip_cache_entry() { + super("remove-zip-cache-entry", PACKAGE_SYS, true, "pathname"); + } + @Override + public LispObject execute(LispObject arg) { + Pathname p = coerceToPathname(arg); + URL url = Pathname.makeURL(p); + boolean result = ZipCache.remove(url); + return result ? T : NIL; + } + } + + + public static boolean remove(URL url) { + Entry entry = zipCache.get(url); + if (entry != null) { + try { + entry.file.close(); + } catch (IOException e) {} + zipCache.remove(entry); + return true; + } + return false; + } + } \ No newline at end of file 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 Wed Feb 10 11:22:21 2010 @@ -567,6 +567,7 @@ while (not (eq line :eof)) do (write-line line out)))) (delete-file temp-file) + (remove-zip-cache-entry output-file) ;; Necessary under windows (rename-file temp-file2 output-file) (when *compile-file-zip* From ehuelsmann at common-lisp.net Wed Feb 10 21:57:05 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 10 Feb 2010 16:57:05 -0500 Subject: [armedbear-cvs] r12442 - branches/metaclass Message-ID: Author: ehuelsmann Date: Wed Feb 10 16:57:01 2010 New Revision: 12442 Log: Move work on METACLASS support to a branch. The impact is too widespread for keeping trunk/ stable. Added: branches/metaclass/ - copied from r12441, /trunk/ From ehuelsmann at common-lisp.net Wed Feb 10 22:56:59 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 10 Feb 2010 17:56:59 -0500 Subject: [armedbear-cvs] r12443 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Feb 10 17:56:56 2010 New Revision: 12443 Log: Revert r12425: it broke trunk in a way not quickly fixed. Work to reinstate 12425 continues on branches/metaclass/. 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 Wed Feb 10 17:56:56 2010 @@ -537,14 +537,7 @@ (defun canonical-slot-name (canonical-slot) (getf canonical-slot :name)) -(defun ensure-class (name &rest all-keys - &key (metaclass 'standard-class) &allow-other-keys) - - ;; Don't pass METACLASS on to the initialization routines - ;; This only works because we *know* ABCL conses up new &rest lists - ;; every time; otherwise, modifying the argument list is discouraged by the spec - (remf all-keys :metaclass) - +(defun ensure-class (name &rest all-keys &allow-other-keys) ;; Check for duplicate slots. (let ((slots (getf all-keys :direct-slots))) (dolist (s1 slots) @@ -589,12 +582,8 @@ (apply #'std-after-initialization-for-classes old-class all-keys) old-class))) (t - (let ((class (apply (if (eq metaclass 'standard-class) - #'make-instance-standard-class - #'make-instance) - (or (when (symbolp metaclass) - (find-class metaclass)) - metaclass) + (let ((class (apply #'make-instance-standard-class + (find-class 'standard-class) :name name all-keys))) (%set-find-class name class) class))))) From ehuelsmann at common-lisp.net Wed Feb 10 23:06:47 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 10 Feb 2010 18:06:47 -0500 Subject: [armedbear-cvs] r12444 - branches/metaclass/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Feb 10 18:06:45 2010 New Revision: 12444 Log: Make the lispClass slot in Layout private and add an additional constructor to StandardObject which takes a layout instead of a class. This change is required to be able to bootstrap StandardClass. Modified: branches/metaclass/abcl/src/org/armedbear/lisp/Layout.java branches/metaclass/abcl/src/org/armedbear/lisp/StandardObject.java Modified: branches/metaclass/abcl/src/org/armedbear/lisp/Layout.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/Layout.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/Layout.java Wed Feb 10 18:06:45 2010 @@ -35,9 +35,9 @@ import static org.armedbear.lisp.Lisp.*; -public final class Layout extends LispObject +public class Layout extends LispObject { - public final LispClass lispClass; + private final LispClass lispClass; public final EqHashTable slotTable; private final LispObject[] slotNames; @@ -76,7 +76,7 @@ // Copy constructor. private Layout(Layout oldLayout) { - lispClass = oldLayout.lispClass; + lispClass = oldLayout.getLispClass(); slotNames = oldLayout.slotNames; sharedSlots = oldLayout.sharedSlots; slotTable = initializeSlotTable(slotNames); @@ -94,7 +94,7 @@ public LispObject getParts() { LispObject result = NIL; - result = result.push(new Cons("class", lispClass)); + result = result.push(new Cons("class", getLispClass())); for (int i = 0; i < slotNames.length; i++) { result = result.push(new Cons("slot " + i, slotNames[i])); @@ -103,6 +103,11 @@ return result.nreverse(); } + public LispClass getLispClass() + { + return lispClass; + } + public boolean isInvalid() { return invalid; @@ -167,7 +172,7 @@ @Override public LispObject execute(LispObject arg) { - return checkLayout(arg).lispClass; + return checkLayout(arg).getLispClass(); } }; Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StandardObject.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/StandardObject.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/StandardObject.java Wed Feb 10 18:06:45 2010 @@ -45,9 +45,19 @@ layout = new Layout(StandardClass.STANDARD_OBJECT, NIL, NIL); } + + protected StandardObject(Layout layout, int length) + { + this.layout = layout; + slots = new LispObject[length]; + for (int i = slots.length; i-- > 0;) + slots[i] = UNBOUND_VALUE; + } + + protected StandardObject(LispClass cls, int length) { - layout = cls.getClassLayout(); + layout = cls == null ? null : cls.getClassLayout(); slots = new LispObject[length]; for (int i = slots.length; i-- > 0;) slots[i] = UNBOUND_VALUE; @@ -55,8 +65,8 @@ protected StandardObject(LispClass cls) { - layout = cls.getClassLayout(); - slots = new LispObject[layout.getLength()]; + layout = cls == null ? null : cls.getClassLayout(); + slots = new LispObject[layout == null ? 0 : layout.getLength()]; for (int i = slots.length; i-- > 0;) slots[i] = UNBOUND_VALUE; } @@ -90,7 +100,7 @@ public final LispClass getLispClass() { - return layout.lispClass; + return layout.getLispClass(); } @Override @@ -100,7 +110,7 @@ // conditions, TYPE-OF returns the proper name of the class returned by // CLASS-OF if it has a proper name, and otherwise returns the class // itself." - final LispClass c1 = layout.lispClass; + final LispClass c1 = layout.getLispClass(); // The proper name of a class is "a symbol that names the class whose // name is that symbol". final Symbol symbol = c1.getSymbol(); @@ -117,7 +127,7 @@ @Override public LispObject classOf() { - return layout.lispClass; + return layout.getLispClass(); } @Override @@ -127,7 +137,7 @@ return T; if (type == StandardClass.STANDARD_OBJECT) return T; - LispClass cls = layout != null ? layout.lispClass : null; + LispClass cls = layout != null ? layout.getLispClass() : null; if (cls != null) { if (type == cls) @@ -173,7 +183,7 @@ { Debug.assertTrue(layout.isInvalid()); Layout oldLayout = layout; - LispClass cls = oldLayout.lispClass; + LispClass cls = oldLayout.getLispClass(); Layout newLayout = cls.getClassLayout(); Debug.assertTrue(!newLayout.isInvalid()); StandardObject newInstance = new StandardObject(cls); @@ -340,7 +350,7 @@ @Override public LispObject execute(LispObject arg) { - return checkStandardObject(arg).layout.lispClass; + return checkStandardObject(arg).layout.getLispClass(); } }; From mevenson at common-lisp.net Thu Feb 11 11:54:56 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Thu, 11 Feb 2010 06:54:56 -0500 Subject: [armedbear-cvs] r12445 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu Feb 11 06:54:53 2010 New Revision: 12445 Log: Set SVN properties. Modified: trunk/abcl/src/org/armedbear/lisp/ZipCache.java (contents, props changed) 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 Thu Feb 11 06:54:53 2010 @@ -2,7 +2,7 @@ * ZipCache.java * * Copyright (C) 2003-2007 Peter Graves - * $Id: Pathname.java 12435 2010-02-09 15:42:58Z mevenson $ + * $Id$ * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License From mevenson at common-lisp.net Thu Feb 11 12:00:43 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Thu, 11 Feb 2010 07:00:43 -0500 Subject: [armedbear-cvs] r12446 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu Feb 11 07:00:42 2010 New Revision: 12446 Log: Correct copyright. 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 Thu Feb 11 07:00:42 2010 @@ -1,7 +1,7 @@ /* * ZipCache.java * - * Copyright (C) 2003-2007 Peter Graves + * Copyright (C) 2010 Mark Evenson * $Id$ * * This program is free software; you can redistribute it and/or From mevenson at common-lisp.net Thu Feb 11 12:04:00 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Thu, 11 Feb 2010 07:04:00 -0500 Subject: [armedbear-cvs] r12447 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu Feb 11 07:03:56 2010 New Revision: 12447 Log: REQUIRE now searches for ASDF systems. If ASDF is loaded via (REQUIRE 'ASDF), all subsequent invocations of REQUIRE will search for a loadable ASDF system definitions if the default resolver mechanism fails. SYS::*MODULE-PROVIDER-FUNCTIONS* now contains a customizable list of module provider functions. Such a function takes a single argument of the module that should be resolved and loaded. There is a builtin resolver #'SYS::MODULE-PROVIDE-SYSTEM that implicitly called before any functions in this variable. Modified: trunk/abcl/src/org/armedbear/lisp/asdf-abcl.lisp trunk/abcl/src/org/armedbear/lisp/require.lisp Modified: trunk/abcl/src/org/armedbear/lisp/asdf-abcl.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf-abcl.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/asdf-abcl.lisp Thu Feb 11 07:03:56 2010 @@ -44,5 +44,21 @@ (if (every #'sys:pathname-jar-p files) t (call-next-method)))) + +(defun module-provide-asdf (name) + (handler-case + (let* ((*verbose-out* (make-broadcast-stream)) + (system (asdf:find-system name nil))) + (when system + (asdf:operate 'asdf:load-op name) + t)) + (missing-component (e) + (declare (ignore e)) + nil) + (t (e) + (format *error-output* "ASDF could not load ~A because ~A.~%" + name e)))) + +(pushnew #'module-provide-asdf sys::*module-provider-functions*) (provide 'asdf-abcl) Modified: trunk/abcl/src/org/armedbear/lisp/require.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/require.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/require.lisp Thu Feb 11 07:03:56 2010 @@ -36,6 +36,20 @@ (pushnew (string module-name) *modules* :test #'string=) t) +(defun module-provide-system (module) + (let ((*readtable* (copy-readtable nil))) + (handler-case + (load-system-file (string-downcase (string module))) + (t (e) + (unless (and (typep e 'error) + (search "Failed to find loadable system file" + (format nil "~A" e))) + (format *error-output* "Failed to require ~A because '~A'~%" + module e)) + nil)))) + +(defvar *module-provider-functions* nil) + (defun require (module-name &optional pathnames) (unless (member (string module-name) *modules* :test #'string=) (let ((saved-modules (copy-list *modules*))) @@ -44,6 +58,9 @@ (dolist (x pathnames) (load x))) (t - (let ((*readtable* (copy-readtable nil))) - (load-system-file (string-downcase (string module-name)))))) + (unless (some (lambda (p) (funcall p module-name)) + (append (list #'module-provide-system) + sys::*module-provider-functions*)) + (error "Don't know how to ~S ~A." 'require module-name)))) (set-difference *modules* saved-modules)))) + From mevenson at common-lisp.net Thu Feb 11 12:16:52 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Thu, 11 Feb 2010 07:16:52 -0500 Subject: [armedbear-cvs] r12448 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu Feb 11 07:16:51 2010 New Revision: 12448 Log: Remove potentially present ZipCache files entries on DELETE-FILE and RENAME-FILE. Corrects failing COMPILE-FILE.* ANSI-TESTs under Windows. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/src/org/armedbear/lisp/ZipCache.java trunk/abcl/src/org/armedbear/lisp/delete_file.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 Feb 11 07:16:51 2010 @@ -1896,6 +1896,7 @@ final File destination = new File(newNamestring); if (Utilities.isPlatformWindows) { if (destination.isFile()) { + ZipCache.remove(destination); destination.delete(); } } 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 Thu Feb 11 07:16:51 2010 @@ -166,13 +166,11 @@ @Override public LispObject execute(LispObject arg) { Pathname p = coerceToPathname(arg); - URL url = Pathname.makeURL(p); - boolean result = ZipCache.remove(url); + boolean result = ZipCache.remove(p); return result ? T : NIL; } } - public static boolean remove(URL url) { Entry entry = zipCache.get(url); if (entry != null) { @@ -184,4 +182,18 @@ } return false; } - } \ No newline at end of file + + public static boolean remove(Pathname p) { + URL url = Pathname.makeURL(p); + if (url == null) { + return false; + } + return ZipCache.remove(url); + } + + public static boolean remove(File f) { + Pathname p = Pathname.makePathname(f); + return ZipCache.remove(p); + } + +} \ No newline at end of file Modified: trunk/abcl/src/org/armedbear/lisp/delete_file.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/delete_file.java (original) +++ trunk/abcl/src/org/armedbear/lisp/delete_file.java Thu Feb 11 07:16:51 2010 @@ -68,6 +68,7 @@ return error(new FileError("Pathname has no namestring: " + defaultedPathname.writeToString(), defaultedPathname)); final File file = new File(namestring); + ZipCache.remove(file); if (file.exists()) { // File exists. for (int i = 0; i < 5; i++) { From mevenson at common-lisp.net Fri Feb 12 08:27:37 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 12 Feb 2010 03:27:37 -0500 Subject: [armedbear-cvs] r12449 - trunk/abcl/nbproject Message-ID: Author: mevenson Date: Fri Feb 12 03:27:34 2010 New Revision: 12449 Log: Include manifest in Netbeans build so that abcl.jar is executable. Found by Paul Griffioen. Modified: trunk/abcl/nbproject/project.properties Modified: trunk/abcl/nbproject/project.properties ============================================================================== --- trunk/abcl/nbproject/project.properties (original) +++ trunk/abcl/nbproject/project.properties Fri Feb 12 03:27:34 2010 @@ -32,8 +32,8 @@ javac.test.classpath=\ ${javac.classpath}:\ ${build.classes.dir}:\ - ${libs.junit.classpath}:\ - ${libs.junit_4.classpath} + ${libs.junit_4.classpath}:\ + ${libs.junit.classpath} javadoc.additionalparam= javadoc.author=false javadoc.encoding=${source.encoding} @@ -52,7 +52,7 @@ jnlp.offline-allowed=false jnlp.signed=false main.class=org.armedbear.lisp.Main -manifest.file=manifest.mf +manifest.file=src/manifest-abcl meta.inf.dir=${src.dir}/META-INF platform.active=default_platform run.classpath=\ From mevenson at common-lisp.net Fri Feb 12 10:53:31 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 12 Feb 2010 05:53:31 -0500 Subject: [armedbear-cvs] r12450 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Feb 12 05:53:28 2010 New Revision: 12450 Log: Collect unprocessed command-line arguments in EXT:*COMMAND-LINE-ARGUMENT-LIST*. Contributed by Dennis Lambe Jr. Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java trunk/abcl/src/org/armedbear/lisp/Lisp.java Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Interpreter.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Interpreter.java Fri Feb 12 05:53:28 2010 @@ -211,10 +211,13 @@ } // Check for --noinit; verify that arguments are supplied for --load and - // --eval options. + // --eval options. Copy all unrecognized arguments into + // ext:*command-line-argument-list* private static void preprocessCommandLineArguments(String[] args) { + LispObject arglist = NIL; + if (args != null) { for (int i = 0; i < args.length; ++i) { String arg = args[i]; @@ -239,9 +242,13 @@ System.err.println("No argument supplied to --load"); System.exit(1); } + } else { + arglist = new Cons(args[i], arglist); } } } + + _COMMAND_LINE_ARGUMENT_LIST_.setSymbolValue(arglist); } // Do the --load and --eval actions. 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 Fri Feb 12 05:53:28 2010 @@ -2566,6 +2566,10 @@ public static final Symbol _SAVED_BACKTRACE_ = exportSpecial("*SAVED-BACKTRACE*", PACKAGE_EXT, NIL); + // ### *command-line-argument-list* + public static final Symbol _COMMAND_LINE_ARGUMENT_LIST_ = + exportSpecial("*COMMAND-LINE-ARGUMENT-LIST*", PACKAGE_EXT, NIL); + // ### *batch-mode* public static final Symbol _BATCH_MODE_ = exportSpecial("*BATCH-MODE*", PACKAGE_EXT, NIL); From mevenson at common-lisp.net Fri Feb 12 11:08:21 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 12 Feb 2010 06:08:21 -0500 Subject: [armedbear-cvs] r12451 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Feb 12 06:08:20 2010 New Revision: 12451 Log: Fix for ZipException under interpreted ANSI tests. Check that the cache entries still accesses an open ZipFile when it is handed out. Use SYS:DISABLE-ZIP-CACHE to disable the ZipCache entirely. Implemented some notion of thread synchronization, although we cannot guard against the case where two or more references to a ZipFile exist, and one thread closes the ZipFile. Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/ZipCache.java Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Fri Feb 12 06:08:20 2010 @@ -606,6 +606,7 @@ autoload(PACKAGE_SYS, "create-new-file", "create_new_file"); autoload(PACKAGE_SYS, "default-time-zone", "Time"); autoload(PACKAGE_SYS, "disassemble-class-bytes", "disassemble_class_bytes", true); + autoload(PACKAGE_SYS, "disable-zip-cache", "ZipCache", true); autoload(PACKAGE_SYS, "double-float-high-bits", "FloatFunctions", true); autoload(PACKAGE_SYS, "double-float-low-bits", "FloatFunctions", true); autoload(PACKAGE_SYS, "float-infinity-p", "FloatFunctions", true); 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 Fri Feb 12 06:08:20 2010 @@ -36,71 +36,140 @@ import static org.armedbear.lisp.Lisp.*; import java.io.File; +import java.io.InputStream; import java.io.IOException; import java.net.JarURLConnection; import java.net.MalformedURLException; import java.net.URL; import java.net.URLConnection; +import java.util.Enumeration; import java.util.HashMap; import java.util.zip.ZipException; import java.util.zip.ZipFile; +import java.util.zip.ZipEntry; /** * A cache for all zip/jar file accesses by URL that uses the last * modified time of the cached resource. + * + * This implementation is NOT thread safe, although usage without + * multiple threads recompiling code that is then re-loaded should be + * fine. + * + * If you run into problems with caching, use + * (SYS::DISABLE-ZIP-CACHE). Once disabled, the caching cannot be + * re-enabled. + * */ public class ZipCache { - static class Entry { - long lastModified; - ZipFile file; - } - - static HashMap zipCache = new HashMap(); - - public static ZipFile get(LispObject arg) { - return get(Pathname.makeURL(arg)); - } - - public static ZipFile get(URL url) { - Entry entry = zipCache.get(url); - if (entry != null) { - if (url.getProtocol().equals("file")) { - File f = new File(url.getPath()); + + // To make this thread safe, we should return a proxy for ZipFile + // that keeps track of the number of outstanding references handed + // out, not allowing ZipFile.close() to succeed until that count + // has been reduced to 1 or the finalizer is executing. + // Unfortunately the relatively simple strategy of extended + // ZipFile via a CachedZipFile does not work because there is not + // a null arg constructor for ZipFile. + static class Entry { + long lastModified; + ZipFile file; + } + + static boolean cacheEnabled = true; + + private final static Primitive DISABLE_ZIP_CACHE = new disable_zip_cache(); + final static class disable_zip_cache extends Primitive { + disable_zip_cache() { + super("disable-zip-cache", PACKAGE_SYS, true, "", + "Disable all caching of ABCL FASLs and ZIPs."); + } + @Override + public LispObject execute() { + ZipCache.disable(); + return T; + } + } + + static public synchronized void disable() { + cacheEnabled = false; + zipCache.clear(); + } + + static HashMap zipCache = new HashMap(); + + synchronized public static ZipFile get(LispObject arg) { + return get(Pathname.makeURL(arg)); + } + + synchronized public static ZipFile get(final URL url) { + if (!cacheEnabled) { + if (url.getProtocol().equals("file")) { + File f = new File(url.getPath()); + try { + return new ZipFile(f); + } catch (ZipException e) { + Debug.trace(e); // XXX + return null; + } catch (IOException e) { + Debug.trace(e); // XXX + return null; + } + } else { + Entry e = fetchURL(url, false); + return e.file; + } + } + + Entry entry = zipCache.get(url); + + // Check that the cache entry still accesses a valid ZipFile + if (entry != null) { + // Simplest way to call private ZipFile.ensureOpen() + try { + int size = entry.file.size(); + } catch (IllegalStateException e) { + zipCache.remove(url); + entry = null; + } + } + + if (entry != null) { + if (url.getProtocol().equals("file")) { + File f = new File(url.getPath()); long current = f.lastModified(); if (current > entry.lastModified) { try { - entry.file.close(); - entry.file = new ZipFile(f); - entry.lastModified = current; + entry.file = new ZipFile(f); + entry.lastModified = current; } catch (IOException e) { Debug.trace(e.toString()); // XXX } } } else { - // Unfortunately, the Apple JDK under OS X doesn't do - // HTTP HEAD requests, instead refetching the entire - // resource, so the following code is a waste. I assume - // this is the case in all Sun-dervied JVMs. We'll have - // to implement a custom HTTP lastModified checker. - - // URLConnection connection; - // try { - // connection = url.openConnection(); - // } catch (IOException ex) { - // Debug.trace("Failed to open " - // + "'" + url + "'"); - // return null; - // } - // long current = connection.getLastModified(); - // if (current > entry.lastModified) { - // try { - // entry.file.close(); - // } catch (IOException ex) {} - // entry = fetchURL(url, false); - // } + // Unfortunately, the Apple JDK under OS X doesn't do + // HTTP HEAD requests, instead refetching the entire + // resource, so the following code is a waste. I assume + // this is the case in all Sun-dervied JVMs. We'll have + // to implement a custom HTTP lastModified checker. + + // URLConnection connection; + // try { + // connection = url.openConnection(); + // } catch (IOException ex) { + // Debug.trace("Failed to open " + // + "'" + url + "'"); + // return null; + // } + // long current = connection.getLastModified(); + // if (current > entry.lastModified) { + // try { + // entry.file.close(); + // } catch (IOException ex) {} + // entry = fetchURL(url, false); + // } } } else { - if (url.getProtocol().equals("file")) { + if (url.getProtocol().equals("file")) { entry = new Entry(); File f = new File(url.getPath()); entry.lastModified = f.lastModified(); @@ -119,81 +188,78 @@ zipCache.put(url, entry); } return entry.file; - } + } - static private Entry fetchURL(URL url, boolean cached) { - Entry result = new Entry(); - URL jarURL = null; - try { - jarURL = new URL("jar:" + url + "!/"); - } catch (MalformedURLException e) { - Debug.trace(e); - Debug.assertTrue(false); // XXX - } - URLConnection connection; - try { - connection = jarURL.openConnection(); - } catch (IOException ex) { - Debug.trace("Failed to open " - + "'" + jarURL + "'"); - return null; - } - if (!(connection instanceof JarURLConnection)) { - // XXX - Debug.trace("Could not get a URLConnection from " + jarURL); - return null; - } - JarURLConnection jarURLConnection = (JarURLConnection) connection; - jarURLConnection.setUseCaches(cached); - try { - result.file = jarURLConnection.getJarFile(); - } catch (IOException e) { - Debug.trace(e); - Debug.assertTrue(false); // XXX - } - result.lastModified = jarURLConnection.getLastModified(); - return result; - } + static private Entry fetchURL(URL url, boolean cached) { + Entry result = new Entry(); + URL jarURL = null; + try { + jarURL = new URL("jar:" + url + "!/"); + } catch (MalformedURLException e) { + Debug.trace(e); + Debug.assertTrue(false); // XXX + } + URLConnection connection; + try { + connection = jarURL.openConnection(); + } catch (IOException ex) { + Debug.trace("Failed to open " + + "'" + jarURL + "'"); + return null; + } + if (!(connection instanceof JarURLConnection)) { + // XXX + Debug.trace("Could not get a URLConnection from " + jarURL); + return null; + } + JarURLConnection jarURLConnection = (JarURLConnection) connection; + jarURLConnection.setUseCaches(cached); + try { + result.file = jarURLConnection.getJarFile(); + } catch (IOException e) { + Debug.trace(e); + Debug.assertTrue(false); // XXX + } + result.lastModified = jarURLConnection.getLastModified(); + return result; + } + // ## remove-zip-cache-entry pathname => boolean + private static final Primitive REMOVE_ZIP_CACHE_ENTRY = new remove_zip_cache_entry(); + private static class remove_zip_cache_entry extends Primitive { + remove_zip_cache_entry() { + super("remove-zip-cache-entry", PACKAGE_SYS, true, "pathname"); + } + @Override + public LispObject execute(LispObject arg) { + Pathname p = coerceToPathname(arg); + boolean result = ZipCache.remove(p); + return result ? T : NIL; + } + } + + synchronized public static boolean remove(URL url) { + Entry entry = zipCache.get(url); + if (entry != null) { + try { + entry.file.close(); + } catch (IOException e) {} + zipCache.remove(entry); + return true; + } + return false; + } + synchronized public static boolean remove(Pathname p) { + URL url = Pathname.makeURL(p); + if (url == null) { + return false; + } + return ZipCache.remove(url); + } - // ## remove-zip-cache-entry pathname => boolean - private static final Primitive REMOVE_ZIP_CACHE_ENTRY = new remove_zip_cache_entry(); - private static class remove_zip_cache_entry extends Primitive { - remove_zip_cache_entry() { - super("remove-zip-cache-entry", PACKAGE_SYS, true, "pathname"); - } - @Override - public LispObject execute(LispObject arg) { - Pathname p = coerceToPathname(arg); - boolean result = ZipCache.remove(p); - return result ? T : NIL; + synchronized public static boolean remove(File f) { + Pathname p = Pathname.makePathname(f); + return ZipCache.remove(p); } - } - - public static boolean remove(URL url) { - Entry entry = zipCache.get(url); - if (entry != null) { - try { - entry.file.close(); - } catch (IOException e) {} - zipCache.remove(entry); - return true; - } - return false; - } - - public static boolean remove(Pathname p) { - URL url = Pathname.makeURL(p); - if (url == null) { - return false; - } - return ZipCache.remove(url); - } - - public static boolean remove(File f) { - Pathname p = Pathname.makePathname(f); - return ZipCache.remove(p); - } - } \ No newline at end of file From ehuelsmann at common-lisp.net Fri Feb 12 20:34:40 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 12 Feb 2010 15:34:40 -0500 Subject: [armedbear-cvs] r12452 - branches/metaclass/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Feb 12 15:34:37 2010 New Revision: 12452 Log: Unbind functions before defining generic functions for them. Modified: branches/metaclass/abcl/src/org/armedbear/lisp/clos.lisp Modified: branches/metaclass/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/clos.lisp Fri Feb 12 15:34:37 2010 @@ -1792,6 +1792,7 @@ ))) (fmakunbound 'class-name) +(fmakunbound '(setf class-name)) (defgeneric class-name (class)) @@ -1811,6 +1812,9 @@ (defmethod class-precedence-list ((class class)) (%class-precedence-list class)) + + +(fmakunbound 'documentation) (defgeneric documentation (x doc-type)) (defgeneric (setf documentation) (new-value x doc-type)) @@ -2400,4 +2404,5 @@ ;; FIXME (defgeneric function-keywords (method)) + (provide 'clos) From vvoutilainen at common-lisp.net Fri Feb 12 21:22:03 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Fri, 12 Feb 2010 16:22:03 -0500 Subject: [armedbear-cvs] r12453 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Fri Feb 12 16:22:02 2010 New Revision: 12453 Log: Make Primitives stack-friendly. Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.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 Fri Feb 12 16:22:02 2010 @@ -41,9 +41,13 @@ public final class Primitives { // ### * - public static final Primitive MULTIPLY = - new Primitive(Symbol.STAR, "&rest numbers") - { + public static final Primitive MULTIPLY = new pf_multiply(); + private static final class pf_multiply extends Primitive { + pf_multiply() + { + super(Symbol.STAR, "&rest numbers"); + } + @Override public LispObject execute() { @@ -73,9 +77,13 @@ }; // ### / - public static final Primitive DIVIDE = - new Primitive(Symbol.SLASH, "numerator &rest denominators") - { + public static final Primitive DIVIDE = new pf_divide(); + private static final class pf_divide extends Primitive { + pf_divide() + { + super(Symbol.SLASH, "numerator &rest denominators"); + } + @Override public LispObject execute() { @@ -103,9 +111,13 @@ }; // ### min - public static final Primitive MIN = - new Primitive(Symbol.MIN, "&rest reals") - { + public static final Primitive MIN = new pf_min(); + private static final class pf_min extends Primitive { + pf_min() + { + super(Symbol.MIN, "&rest reals"); + } + @Override public LispObject execute() { @@ -140,9 +152,13 @@ }; // ### max - public static final Primitive MAX = - new Primitive(Symbol.MAX, "&rest reals") - { + public static final Primitive MAX = new pf_max(); + private static final class pf_max extends Primitive { + pf_max() + { + super(Symbol.MAX, "&rest reals"); + } + @Override public LispObject execute() { @@ -177,9 +193,13 @@ }; // ### identity - private static final Primitive IDENTITY = - new Primitive(Symbol.IDENTITY, "object") - { + private static final Primitive IDENTITY = new pf_identity(); + private static final class pf_identity extends Primitive { + pf_identity() + { + super(Symbol.IDENTITY, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -188,9 +208,13 @@ }; // ### compiled-function-p - private static final Primitive COMPILED_FUNCTION_P = - new Primitive(Symbol.COMPILED_FUNCTION_P, "object") - { + private static final Primitive COMPILED_FUNCTION_P = new pf_compiled_function_p(); + private static final class pf_compiled_function_p extends Primitive { + pf_compiled_function_p() + { + super(Symbol.COMPILED_FUNCTION_P, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -199,9 +223,13 @@ }; // ### consp - private static final Primitive CONSP = - new Primitive(Symbol.CONSP, "object") - { + private static final Primitive CONSP = new pf_consp(); + private static final class pf_consp extends Primitive { + pf_consp() + { + super(Symbol.CONSP, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -210,9 +238,13 @@ }; // ### listp - private static final Primitive LISTP = - new Primitive(Symbol.LISTP, "object") - { + private static final Primitive LISTP = new pf_listp(); + private static final class pf_listp extends Primitive { + pf_listp() + { + super(Symbol.LISTP, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -221,9 +253,13 @@ }; // ### abs - private static final Primitive ABS = - new Primitive(Symbol.ABS, "number") - { + private static final Primitive ABS = new pf_abs(); + private static final class pf_abs extends Primitive { + pf_abs() + { + super(Symbol.ABS, "number"); + } + @Override public LispObject execute(LispObject arg) { @@ -232,9 +268,13 @@ }; // ### arrayp - private static final Primitive ARRAYP = - new Primitive(Symbol.ARRAYP, "object") - { + private static final Primitive ARRAYP = new pf_arrayp(); + private static final class pf_arrayp extends Primitive { + pf_arrayp() + { + super(Symbol.ARRAYP, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -243,9 +283,13 @@ }; // ### array-has-fill-pointer-p - private static final Primitive ARRAY_HAS_FILL_POINTER_P = - new Primitive(Symbol.ARRAY_HAS_FILL_POINTER_P, "array") - { + private static final Primitive ARRAY_HAS_FILL_POINTER_P = new pf_array_has_fill_pointer_p(); + private static final class pf_array_has_fill_pointer_p extends Primitive { + pf_array_has_fill_pointer_p() + { + super(Symbol.ARRAY_HAS_FILL_POINTER_P, "array"); + } + @Override public LispObject execute(LispObject arg) { @@ -254,9 +298,13 @@ }; // ### vectorp - private static final Primitive VECTORP = - new Primitive(Symbol.VECTORP, "object") - { + private static final Primitive VECTORP = new pf_vectorp(); + private static final class pf_vectorp extends Primitive { + pf_vectorp() + { + super(Symbol.VECTORP, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -265,9 +313,13 @@ }; // ### simple-vector-p - private static final Primitive SIMPLE_VECTOR_P = - new Primitive(Symbol.SIMPLE_VECTOR_P, "object") - { + private static final Primitive SIMPLE_VECTOR_P = new pf_simple_vector_p(); + private static final class pf_simple_vector_p extends Primitive { + pf_simple_vector_p() + { + super(Symbol.SIMPLE_VECTOR_P, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -276,9 +328,13 @@ }; // ### bit-vector-p - private static final Primitive BIT_VECTOR_P = - new Primitive(Symbol.BIT_VECTOR_P, "object") - { + private static final Primitive BIT_VECTOR_P = new pf_bit_vector_p(); + private static final class pf_bit_vector_p extends Primitive { + pf_bit_vector_p() + { + super(Symbol.BIT_VECTOR_P, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -287,9 +343,13 @@ }; // ### simple-bit-vector-p - private static final Primitive SIMPLE_BIT_VECTOR_P = - new Primitive(Symbol.SIMPLE_BIT_VECTOR_P, "object") - { + private static final Primitive SIMPLE_BIT_VECTOR_P = new pf_simple_bit_vector_p(); + private static final class pf_simple_bit_vector_p extends Primitive { + pf_simple_bit_vector_p() + { + super(Symbol.SIMPLE_BIT_VECTOR_P, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -298,9 +358,13 @@ }; // ### %eval - private static final Primitive _EVAL = - new Primitive("%eval", PACKAGE_SYS, false, "form") - { + private static final Primitive _EVAL = new pf__eval(); + private static final class pf__eval extends Primitive { + pf__eval() + { + super("%eval", PACKAGE_SYS, false, "form"); + } + @Override public LispObject execute(LispObject arg) { @@ -309,8 +373,13 @@ }; // ### eq - private static final Primitive EQ = new Primitive(Symbol.EQ, "x y") - { + private static final Primitive EQ = new pf_eq(); + private static final class pf_eq extends Primitive { + pf_eq() + { + super(Symbol.EQ, "x y"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -320,8 +389,13 @@ }; // ### eql - private static final Primitive EQL = new Primitive(Symbol.EQL, "x y") - { + private static final Primitive EQL = new pf_eql(); + private static final class pf_eql extends Primitive { + pf_eql() + { + super(Symbol.EQL, "x y"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -331,8 +405,13 @@ }; // ### equal - private static final Primitive EQUAL = new Primitive(Symbol.EQUAL, "x y") - { + private static final Primitive EQUAL = new pf_equal(); + private static final class pf_equal extends Primitive { + pf_equal() + { + super(Symbol.EQUAL, "x y"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -342,8 +421,13 @@ }; // ### equalp - private static final Primitive EQUALP = new Primitive(Symbol.EQUALP, "x y") - { + private static final Primitive EQUALP = new pf_equalp(); + private static final class pf_equalp extends Primitive { + pf_equalp() + { + super(Symbol.EQUALP, "x y"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -353,9 +437,13 @@ }; // ### values - private static final Primitive VALUES = - new Primitive(Symbol.VALUES, "&rest object") - { + private static final Primitive VALUES = new pf_values(); + private static final class pf_values extends Primitive { + pf_values() + { + super(Symbol.VALUES, "&rest object"); + } + @Override public LispObject execute() { @@ -393,9 +481,13 @@ // ### values-list list => element* // Returns the elements of the list as multiple values. - private static final Primitive VALUES_LIST = - new Primitive(Symbol.VALUES_LIST, "list") - { + private static final Primitive VALUES_LIST = new pf_values_list(); + private static final class pf_values_list extends Primitive { + pf_values_list() + { + super(Symbol.VALUES_LIST, "list"); + } + @Override public LispObject execute(LispObject arg) { @@ -408,9 +500,13 @@ }; // ### cons - private static final Primitive CONS = - new Primitive(Symbol.CONS, "object-1 object-2") - { + private static final Primitive CONS = new pf_cons(); + private static final class pf_cons extends Primitive { + pf_cons() + { + super(Symbol.CONS, "object-1 object-2"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -420,9 +516,13 @@ }; // ### length - private static final Primitive LENGTH = - new Primitive(Symbol.LENGTH, "sequence") - { + private static final Primitive LENGTH = new pf_length(); + private static final class pf_length extends Primitive { + pf_length() + { + super(Symbol.LENGTH, "sequence"); + } + @Override public LispObject execute(LispObject arg) { @@ -431,9 +531,13 @@ }; // ### elt - private static final Primitive ELT = - new Primitive(Symbol.ELT, "sequence index") - { + private static final Primitive ELT = new pf_elt(); + private static final class pf_elt extends Primitive { + pf_elt() + { + super(Symbol.ELT, "sequence index"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -443,8 +547,13 @@ }; // ### atom - private static final Primitive ATOM = new Primitive(Symbol.ATOM, "object") - { + private static final Primitive ATOM = new pf_atom(); + private static final class pf_atom extends Primitive { + pf_atom() + { + super(Symbol.ATOM, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -453,9 +562,13 @@ }; // ### constantp - private static final Primitive CONSTANTP = - new Primitive(Symbol.CONSTANTP, "form &optional environment") - { + private static final Primitive CONSTANTP = new pf_constantp(); + private static final class pf_constantp extends Primitive { + pf_constantp() + { + super(Symbol.CONSTANTP, "form &optional environment"); + } + @Override public LispObject execute(LispObject arg) { @@ -470,9 +583,13 @@ }; // ### functionp - private static final Primitive FUNCTIONP = - new Primitive(Symbol.FUNCTIONP, "object") - { + private static final Primitive FUNCTIONP = new pf_functionp(); + private static final class pf_functionp extends Primitive { + pf_functionp() + { + super(Symbol.FUNCTIONP, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -481,9 +598,13 @@ }; // ### special-operator-p - private static final Primitive SPECIAL_OPERATOR_P = - new Primitive(Symbol.SPECIAL_OPERATOR_P, "symbol") - { + private static final Primitive SPECIAL_OPERATOR_P = new pf_special_operator_p(); + private static final class pf_special_operator_p extends Primitive { + pf_special_operator_p() + { + super(Symbol.SPECIAL_OPERATOR_P, "symbol"); + } + @Override public LispObject execute(LispObject arg) { @@ -492,9 +613,13 @@ }; // ### symbolp - private static final Primitive SYMBOLP = - new Primitive(Symbol.SYMBOLP, "object") - { + private static final Primitive SYMBOLP = new pf_symbolp(); + private static final class pf_symbolp extends Primitive { + pf_symbolp() + { + super(Symbol.SYMBOLP, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -503,8 +628,13 @@ }; // ### endp - private static final Primitive ENDP = new Primitive(Symbol.ENDP, "list") - { + private static final Primitive ENDP = new pf_endp(); + private static final class pf_endp extends Primitive { + pf_endp() + { + super(Symbol.ENDP, "list"); + } + @Override public LispObject execute(LispObject arg) { @@ -513,8 +643,13 @@ }; // ### null - private static final Primitive NULL = new Primitive(Symbol.NULL, "object") - { + private static final Primitive NULL = new pf_null(); + private static final class pf_null extends Primitive { + pf_null() + { + super(Symbol.NULL, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -523,8 +658,13 @@ }; // ### not - private static final Primitive NOT = new Primitive(Symbol.NOT, "x") - { + private static final Primitive NOT = new pf_not(); + private static final class pf_not extends Primitive { + pf_not() + { + super(Symbol.NOT, "x"); + } + @Override public LispObject execute(LispObject arg) { @@ -533,8 +673,13 @@ }; // ### plusp - private static final Primitive PLUSP = new Primitive(Symbol.PLUSP, "real") - { + private static final Primitive PLUSP = new pf_plusp(); + private static final class pf_plusp extends Primitive { + pf_plusp() + { + super(Symbol.PLUSP, "real"); + } + @Override public LispObject execute(LispObject arg) { @@ -543,9 +688,13 @@ }; // ### minusp - private static final Primitive MINUSP = - new Primitive(Symbol.MINUSP, "real") - { + private static final Primitive MINUSP = new pf_minusp(); + private static final class pf_minusp extends Primitive { + pf_minusp() + { + super(Symbol.MINUSP, "real"); + } + @Override public LispObject execute(LispObject arg) { @@ -554,9 +703,13 @@ }; // ### zerop - private static final Primitive ZEROP = - new Primitive(Symbol.ZEROP, "number") - { + private static final Primitive ZEROP = new pf_zerop(); + private static final class pf_zerop extends Primitive { + pf_zerop() + { + super(Symbol.ZEROP, "number"); + } + @Override public LispObject execute(LispObject arg) { @@ -565,9 +718,13 @@ }; // ### fixnump - private static final Primitive FIXNUMP = - new Primitive("fixnump", PACKAGE_EXT, true) - { + private static final Primitive FIXNUMP = new pf_fixnump(); + private static final class pf_fixnump extends Primitive { + pf_fixnump() + { + super("fixnump", PACKAGE_EXT, true); + } + @Override public LispObject execute(LispObject arg) { @@ -576,9 +733,13 @@ }; // ### symbol-value - private static final Primitive SYMBOL_VALUE = - new Primitive(Symbol.SYMBOL_VALUE, "symbol") - { + private static final Primitive SYMBOL_VALUE = new pf_symbol_value(); + private static final class pf_symbol_value extends Primitive { + pf_symbol_value() + { + super(Symbol.SYMBOL_VALUE, "symbol"); + } + @Override public LispObject execute(LispObject arg) { @@ -592,9 +753,13 @@ }; // ### set symbol value => value - private static final Primitive SET = - new Primitive(Symbol.SET, "symbol value") - { + private static final Primitive SET = new pf_set(); + private static final class pf_set extends Primitive { + pf_set() + { + super(Symbol.SET, "symbol value"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -605,9 +770,13 @@ }; // ### rplaca - private static final Primitive RPLACA = - new Primitive(Symbol.RPLACA, "cons object") - { + private static final Primitive RPLACA = new pf_rplaca(); + private static final class pf_rplaca extends Primitive { + pf_rplaca() + { + super(Symbol.RPLACA, "cons object"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -618,9 +787,13 @@ }; // ### rplacd - private static final Primitive RPLACD = - new Primitive(Symbol.RPLACD, "cons object") - { + private static final Primitive RPLACD = new pf_rplacd(); + private static final class pf_rplacd extends Primitive { + pf_rplacd() + { + super(Symbol.RPLACD, "cons object"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -631,9 +804,13 @@ }; // ### + - private static final Primitive ADD = - new Primitive(Symbol.PLUS, "&rest numbers") - { + private static final Primitive ADD = new pf_add(); + private static final class pf_add extends Primitive { + pf_add() + { + super(Symbol.PLUS, "&rest numbers"); + } + @Override public LispObject execute() { @@ -671,9 +848,13 @@ }; // ### 1+ - private static final Primitive ONE_PLUS = - new Primitive(Symbol.ONE_PLUS, "number") - { + private static final Primitive ONE_PLUS = new pf_one_plus(); + private static final class pf_one_plus extends Primitive { + pf_one_plus() + { + super(Symbol.ONE_PLUS, "number"); + } + @Override public LispObject execute(LispObject arg) { @@ -682,9 +863,13 @@ }; // ### - - private static final Primitive SUBTRACT = - new Primitive(Symbol.MINUS, "minuend &rest subtrahends") - { + private static final Primitive SUBTRACT = new pf_subtract(); + private static final class pf_subtract extends Primitive { + pf_subtract() + { + super(Symbol.MINUS, "minuend &rest subtrahends"); + } + @Override public LispObject execute() { @@ -712,9 +897,13 @@ }; // ### 1- - private static final Primitive ONE_MINUS = - new Primitive(Symbol.ONE_MINUS, "number") - { + private static final Primitive ONE_MINUS = new pf_one_minus(); + private static final class pf_one_minus extends Primitive { + pf_one_minus() + { + super(Symbol.ONE_MINUS, "number"); + } + @Override public LispObject execute(LispObject arg) { @@ -765,9 +954,13 @@ }; // ### %stream-output-object object stream => object - private static final Primitive _STREAM_OUTPUT_OBJECT = - new Primitive("%stream-output-object", PACKAGE_SYS, true) - { + private static final Primitive _STREAM_OUTPUT_OBJECT = new pf__stream_output_object(); + private static final class pf__stream_output_object extends Primitive { + pf__stream_output_object() + { + super("%stream-output-object", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -778,9 +971,13 @@ }; // ### %output-object object stream => object - private static final Primitive _OUTPUT_OBJECT = - new Primitive("%output-object", PACKAGE_SYS, true) - { + private static final Primitive _OUTPUT_OBJECT = new pf__output_object(); + private static final class pf__output_object extends Primitive { + pf__output_object() + { + super("%output-object", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -798,9 +995,13 @@ }; // ### %write-to-string object => string - private static final Primitive _WRITE_TO_STRING = - new Primitive("%write-to-string", PACKAGE_SYS, false) - { + private static final Primitive _WRITE_TO_STRING = new pf__write_to_string(); + private static final class pf__write_to_string extends Primitive { + pf__write_to_string() + { + super("%write-to-string", PACKAGE_SYS, false); + } + @Override public LispObject execute(LispObject arg) { @@ -809,9 +1010,13 @@ }; // ### %stream-terpri output-stream => nil - private static final Primitive _STREAM_TERPRI = - new Primitive("%stream-terpri", PACKAGE_SYS, true, "output-stream") - { + private static final Primitive _STREAM_TERPRI = new pf__stream_terpri(); + private static final class pf__stream_terpri extends Primitive { + pf__stream_terpri() + { + super("%stream-terpri", PACKAGE_SYS, true, "output-stream"); + } + @Override public LispObject execute(LispObject arg) { @@ -821,9 +1026,13 @@ }; // ### %terpri output-stream => nil - private static final Primitive _TERPRI = - new Primitive("%terpri", PACKAGE_SYS, false, "output-stream") - { + private static final Primitive _TERPRI = new pf__terpri(); + private static final class pf__terpri extends Primitive { + pf__terpri() + { + super("%terpri", PACKAGE_SYS, false, "output-stream"); + } + @Override public LispObject execute(LispObject arg) { @@ -839,9 +1048,13 @@ // ### %fresh-line // %fresh-line &optional output-stream => generalized-boolean - private static final Primitive _FRESH_LINE = - new Primitive("%fresh-line", PACKAGE_SYS, false, "output-stream") - { + private static final Primitive _FRESH_LINE = new pf__fresh_line(); + private static final class pf__fresh_line extends Primitive { + pf__fresh_line() + { + super("%fresh-line", PACKAGE_SYS, false, "output-stream"); + } + @Override public LispObject execute(LispObject arg) { @@ -858,9 +1071,13 @@ // ### boundp // Determines only whether a symbol has a value in the global environment; // any lexical bindings are ignored. - private static final Primitive BOUNDP = - new Primitive(Symbol.BOUNDP, "symbol") - { + private static final Primitive BOUNDP = new pf_boundp(); + private static final class pf_boundp extends Primitive { + pf_boundp() + { + super(Symbol.BOUNDP, "symbol"); + } + @Override public LispObject execute(LispObject arg) { @@ -879,9 +1096,13 @@ }; // ### fboundp - private static final Primitive FBOUNDP = - new Primitive(Symbol.FBOUNDP, "name") - { + private static final Primitive FBOUNDP = new pf_fboundp(); + private static final class pf_fboundp extends Primitive { + pf_fboundp() + { + super(Symbol.FBOUNDP, "name"); + } + @Override public LispObject execute(LispObject arg) { @@ -897,9 +1118,13 @@ }; // ### fmakunbound name => name - private static final Primitive FMAKUNBOUND = - new Primitive(Symbol.FMAKUNBOUND, "name") - { + private static final Primitive FMAKUNBOUND = new pf_fmakunbound(); + private static final class pf_fmakunbound extends Primitive { + pf_fmakunbound() + { + super(Symbol.FMAKUNBOUND, "name"); + } + @Override public LispObject execute(LispObject arg) { @@ -918,9 +1143,13 @@ }; // ### setf-function-name-p - private static final Primitive SETF_FUNCTION_NAME_P = - new Primitive("setf-function-name-p", PACKAGE_SYS, true, "thing") - { + private static final Primitive SETF_FUNCTION_NAME_P = new pf_setf_function_name_p(); + private static final class pf_setf_function_name_p extends Primitive { + pf_setf_function_name_p() + { + super("setf-function-name-p", PACKAGE_SYS, true, "thing"); + } + @Override public LispObject execute(LispObject arg) { @@ -929,9 +1158,13 @@ }; // ### remprop - private static final Primitive REMPROP = - new Primitive(Symbol.REMPROP, "symbol indicator") - { + private static final Primitive REMPROP = new pf_remprop(); + private static final class pf_remprop extends Primitive { + pf_remprop() + { + super(Symbol.REMPROP, "symbol indicator"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -941,9 +1174,13 @@ }; // ### append - public static final Primitive APPEND = - new Primitive(Symbol.APPEND, "&rest lists") - { + public static final Primitive APPEND = new pf_append(); + private static final class pf_append extends Primitive { + pf_append() + { + super(Symbol.APPEND, "&rest lists"); + } + @Override public LispObject execute() { @@ -1044,9 +1281,13 @@ }; // ### nconc - private static final Primitive NCONC = - new Primitive(Symbol.NCONC, "&rest lists") - { + private static final Primitive NCONC = new pf_nconc(); + private static final class pf_nconc extends Primitive { + pf_nconc() + { + super(Symbol.NCONC, "&rest lists"); + } + @Override public LispObject execute() { @@ -1120,9 +1361,13 @@ // ### = // Numeric equality. - private static final Primitive EQUALS = - new Primitive(Symbol.EQUALS, "&rest numbers") - { + private static final Primitive EQUALS = new pf_equals(); + private static final class pf_equals extends Primitive { + pf_equals() + { + super(Symbol.EQUALS, "&rest numbers"); + } + @Override public LispObject execute() { @@ -1165,9 +1410,13 @@ // ### /= // Returns true if no two numbers are the same; otherwise returns false. - private static final Primitive NOT_EQUALS = - new Primitive(Symbol.NOT_EQUALS, "&rest numbers") - { + private static final Primitive NOT_EQUALS = new pf_not_equals(); + private static final class pf_not_equals extends Primitive { + pf_not_equals() + { + super(Symbol.NOT_EQUALS, "&rest numbers"); + } + @Override public LispObject execute() { @@ -1216,9 +1465,13 @@ // ### < // Numeric comparison. - private static final Primitive LT = - new Primitive(Symbol.LT, "&rest numbers") - { + private static final Primitive LT = new pf_lt(); + private static final class pf_lt extends Primitive { + pf_lt() + { + super(Symbol.LT, "&rest numbers"); + } + @Override public LispObject execute() { @@ -1259,9 +1512,13 @@ }; // ### <= - private static final Primitive LE = - new Primitive(Symbol.LE, "&rest numbers") - { + private static final Primitive LE = new pf_le(); + private static final class pf_le extends Primitive { + pf_le() + { + super(Symbol.LE, "&rest numbers"); + } + @Override public LispObject execute() { @@ -1302,9 +1559,13 @@ }; // ### > - private static final Primitive GT = - new Primitive(Symbol.GT, "&rest numbers") - { + private static final Primitive GT = new pf_gt(); + private static final class pf_gt extends Primitive { + pf_gt() + { + super(Symbol.GT, "&rest numbers"); + } + @Override public LispObject execute() { @@ -1345,9 +1606,13 @@ }; // ### >= - private static final Primitive GE = - new Primitive(Symbol.GE, "&rest numbers") - { + private static final Primitive GE = new pf_ge(); + private static final class pf_ge extends Primitive { + pf_ge() + { + super(Symbol.GE, "&rest numbers"); + } + @Override public LispObject execute() { @@ -1388,8 +1653,13 @@ }; // ### nth n list => object - private static final Primitive NTH = new Primitive(Symbol.NTH, "n list") - { + private static final Primitive NTH = new pf_nth(); + private static final class pf_nth extends Primitive { + pf_nth() + { + super(Symbol.NTH, "n list"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -1399,9 +1669,13 @@ }; // ### %set-nth n list new-object => new-object - private static final Primitive _SET_NTH = - new Primitive("%set-nth", PACKAGE_SYS, false) - { + private static final Primitive _SET_NTH = new pf__set_nth(); + private static final class pf__set_nth extends Primitive { + pf__set_nth() + { + super("%set-nth", PACKAGE_SYS, false); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) @@ -1430,9 +1704,13 @@ }; // ### nthcdr - private static final Primitive NTHCDR = - new Primitive(Symbol.NTHCDR, "n list") - { + private static final Primitive NTHCDR = new pf_nthcdr(); + private static final class pf_nthcdr extends Primitive { + pf_nthcdr() + { + super(Symbol.NTHCDR, "n list"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -1453,9 +1731,13 @@ /** Stub to be replaced later when signal.lisp has been loaded. */ // ### error - private static final Primitive ERROR = - new Primitive(Symbol.ERROR, "datum &rest arguments") - { + private static final Primitive ERROR = new pf_error(); + private static final class pf_error extends Primitive { + pf_error() + { + super(Symbol.ERROR, "datum &rest arguments"); + } + @Override public LispObject execute(LispObject[] args) { @@ -1481,9 +1763,13 @@ /** Stub replaced when compiler-pass2.lisp has been loaded */ // ### autocompile - private static final Primitive AUTOCOMPILE = - new Primitive(Symbol.AUTOCOMPILE, "function") - { + private static final Primitive AUTOCOMPILE = new pf_autocompile(); + private static final class pf_autocompile extends Primitive { + pf_autocompile() + { + super(Symbol.AUTOCOMPILE, "function"); + } + @Override public LispObject execute(LispObject function) { @@ -1498,9 +1784,13 @@ * Calling this function is an error: we're not set up for * signalling yet. */ - private static final Primitive SIGNAL = - new Primitive(Symbol.SIGNAL, "datum &rest arguments") - { + private static final Primitive SIGNAL = new pf_signal(); + private static final class pf_signal extends Primitive { + pf_signal() + { + super(Symbol.SIGNAL, "datum &rest arguments"); + } + @Override public LispObject execute(LispObject[] args) { @@ -1514,9 +1804,13 @@ // ### undefined-function-called // Redefined in restart.lisp. - private static final Primitive UNDEFINED_FUNCTION_CALLED = - new Primitive(Symbol.UNDEFINED_FUNCTION_CALLED, "name arguments") - { + private static final Primitive UNDEFINED_FUNCTION_CALLED = new pf_undefined_function_called(); + private static final class pf_undefined_function_called extends Primitive { + pf_undefined_function_called() + { + super(Symbol.UNDEFINED_FUNCTION_CALLED, "name arguments"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -1526,10 +1820,14 @@ }; // ### %format - private static final Primitive _FORMAT = - new Primitive("%format", PACKAGE_SYS, false, - "destination control-string &rest args") - { + private static final Primitive _FORMAT = new pf__format(); + private static final class pf__format extends Primitive { + pf__format() + { + super("%format", PACKAGE_SYS, false, + "destination control-string &rest args"); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) @@ -1664,9 +1962,13 @@ } // ### %defun name definition => name - private static final Primitive _DEFUN = - new Primitive("%defun", PACKAGE_SYS, true, "name definition") - { + private static final Primitive _DEFUN = new pf__defun(); + private static final class pf__defun extends Primitive { + pf__defun() + { + super("%defun", PACKAGE_SYS, true, "name definition"); + } + @Override public LispObject execute(LispObject name, LispObject definition) @@ -1694,9 +1996,13 @@ }; // ### fdefinition-block-name - private static final Primitive FDEFINITION_BLOCK_NAME = - new Primitive("fdefinition-block-name", PACKAGE_SYS, true, "function-name") - { + private static final Primitive FDEFINITION_BLOCK_NAME = new pf_fdefinition_block_name(); + private static final class pf_fdefinition_block_name extends Primitive { + pf_fdefinition_block_name() + { + super("fdefinition-block-name", PACKAGE_SYS, true, "function-name"); + } + @Override public LispObject execute(LispObject arg) { @@ -1709,9 +2015,13 @@ }; // ### macro-function - private static final Primitive MACRO_FUNCTION = - new Primitive(Symbol.MACRO_FUNCTION, "symbol &optional environment") - { + private static final Primitive MACRO_FUNCTION = new pf_macro_function(); + private static final class pf_macro_function extends Primitive { + pf_macro_function() + { + super(Symbol.MACRO_FUNCTION, "symbol &optional environment"); + } + @Override public LispObject execute(LispObject arg) { @@ -1805,9 +2115,13 @@ }; // ### make-macro - private static final Primitive MAKE_MACRO = - new Primitive("make-macro", PACKAGE_SYS, true, "name expansion-function") - { + private static final Primitive MAKE_MACRO = new pf_make_macro(); + private static final class pf_make_macro extends Primitive { + pf_make_macro() + { + super("make-macro", PACKAGE_SYS, true, "name expansion-function"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -1817,9 +2131,13 @@ }; // ### macro-function-p - private static final Primitive MACRO_FUNCTION_P = - new Primitive("macro-function-p", PACKAGE_SYS, true, "value") - { + private static final Primitive MACRO_FUNCTION_P = new pf_macro_function_p(); + private static final class pf_macro_function_p extends Primitive { + pf_macro_function_p() + { + super("macro-function-p", PACKAGE_SYS, true, "value"); + } + @Override public LispObject execute(LispObject arg) { @@ -1829,9 +2147,13 @@ // ### make-symbol-macro - private static final Primitive MAKE_SYMBOL_MACRO = - new Primitive("make-symbol-macro", PACKAGE_SYS, true, "expansion") - { + private static final Primitive MAKE_SYMBOL_MACRO = new pf_make_symbol_macro(); + private static final class pf_make_symbol_macro extends Primitive { + pf_make_symbol_macro() + { + super("make-symbol-macro", PACKAGE_SYS, true, "expansion"); + } + @Override public LispObject execute(LispObject arg) { @@ -1840,9 +2162,13 @@ }; // ### symbol-macro-p - private static final Primitive SYMBOL_MACRO_P = - new Primitive("symbol-macro-p", PACKAGE_SYS, true, "value") - { + private static final Primitive SYMBOL_MACRO_P = new pf_symbol_macro_p(); + private static final class pf_symbol_macro_p extends Primitive { + pf_symbol_macro_p() + { + super("symbol-macro-p", PACKAGE_SYS, true, "value"); + } + @Override public LispObject execute(LispObject arg) { @@ -1851,9 +2177,13 @@ }; // ### %defparameter - private static final Primitive _DEFPARAMETER = - new Primitive("%defparameter", PACKAGE_SYS, false) - { + private static final Primitive _DEFPARAMETER = new pf__defparameter(); + private static final class pf__defparameter extends Primitive { + pf__defparameter() + { + super("%defparameter", PACKAGE_SYS, false); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) @@ -1871,9 +2201,13 @@ }; // ### %defvar - private static final Primitive _DEFVAR = - new Primitive("%defvar", PACKAGE_SYS, false) - { + private static final Primitive _DEFVAR = new pf__defvar(); + private static final class pf__defvar extends Primitive { + pf__defvar() + { + super("%defvar", PACKAGE_SYS, false); + } + @Override public LispObject execute(LispObject arg) { @@ -1894,9 +2228,13 @@ }; // ### %defconstant name initial-value documentation => name - private static final Primitive _DEFCONSTANT = - new Primitive("%defconstant", PACKAGE_SYS, false) - { + private static final Primitive _DEFCONSTANT = new pf__defconstant(); + private static final class pf__defconstant extends Primitive { + pf__defconstant() + { + super("%defconstant", PACKAGE_SYS, false); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) @@ -2061,10 +2399,14 @@ // ### upgraded-array-element-type typespec &optional environment // => upgraded-typespec - private static final Primitive UPGRADED_ARRAY_ELEMENT_TYPE = - new Primitive(Symbol.UPGRADED_ARRAY_ELEMENT_TYPE, - "typespec &optional environment") - { + private static final Primitive UPGRADED_ARRAY_ELEMENT_TYPE = new pf_upgraded_array_element_type(); + private static final class pf_upgraded_array_element_type extends Primitive { + pf_upgraded_array_element_type() + { + super(Symbol.UPGRADED_ARRAY_ELEMENT_TYPE, + "typespec &optional environment"); + } + @Override public LispObject execute(LispObject arg) { @@ -2080,9 +2422,13 @@ }; // ### array-rank array => rank - private static final Primitive ARRAY_RANK = - new Primitive(Symbol.ARRAY_RANK, "array") - { + private static final Primitive ARRAY_RANK = new pf_array_rank(); + private static final class pf_array_rank extends Primitive { + pf_array_rank() + { + super(Symbol.ARRAY_RANK, "array"); + } + @Override public LispObject execute(LispObject arg) { @@ -2093,9 +2439,13 @@ // ### array-dimensions array => dimensions // Returns a list of integers. Fill pointer (if any) is ignored. - private static final Primitive ARRAY_DIMENSIONS = - new Primitive(Symbol.ARRAY_DIMENSIONS, "array") - { + private static final Primitive ARRAY_DIMENSIONS = new pf_array_dimensions(); + private static final class pf_array_dimensions extends Primitive { + pf_array_dimensions() + { + super(Symbol.ARRAY_DIMENSIONS, "array"); + } + @Override public LispObject execute(LispObject arg) { @@ -2104,9 +2454,13 @@ }; // ### array-dimension array axis-number => dimension - private static final Primitive ARRAY_DIMENSION = - new Primitive(Symbol.ARRAY_DIMENSION, "array axis-number") - { + private static final Primitive ARRAY_DIMENSION = new pf_array_dimension(); + private static final class pf_array_dimension extends Primitive { + pf_array_dimension() + { + super(Symbol.ARRAY_DIMENSION, "array axis-number"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -2117,9 +2471,13 @@ }; // ### array-total-size array => size - private static final Primitive ARRAY_TOTAL_SIZE = - new Primitive(Symbol.ARRAY_TOTAL_SIZE, "array") - { + private static final Primitive ARRAY_TOTAL_SIZE = new pf_array_total_size(); + private static final class pf_array_total_size extends Primitive { + pf_array_total_size() + { + super(Symbol.ARRAY_TOTAL_SIZE, "array"); + } + @Override public LispObject execute(LispObject arg) { @@ -2130,9 +2488,13 @@ // ### array-element-type // array-element-type array => typespec - private static final Primitive ARRAY_ELEMENT_TYPE = - new Primitive(Symbol.ARRAY_ELEMENT_TYPE, "array") - { + private static final Primitive ARRAY_ELEMENT_TYPE = new pf_array_element_type(); + private static final class pf_array_element_type extends Primitive { + pf_array_element_type() + { + super(Symbol.ARRAY_ELEMENT_TYPE, "array"); + } + @Override public LispObject execute(LispObject arg) { @@ -2141,9 +2503,13 @@ }; // ### adjustable-array-p - private static final Primitive ADJUSTABLE_ARRAY_P = - new Primitive(Symbol.ADJUSTABLE_ARRAY_P, "array") - { + private static final Primitive ADJUSTABLE_ARRAY_P = new pf_adjustable_array_p(); + private static final class pf_adjustable_array_p extends Primitive { + pf_adjustable_array_p() + { + super(Symbol.ADJUSTABLE_ARRAY_P, "array"); + } + @Override public LispObject execute(LispObject arg) { @@ -2152,9 +2518,13 @@ }; // ### array-displacement array => displaced-to, displaced-index-offset - private static final Primitive ARRAY_DISPLACEMENT = - new Primitive(Symbol.ARRAY_DISPLACEMENT, "array") - { + private static final Primitive ARRAY_DISPLACEMENT = new pf_array_displacement(); + private static final class pf_array_displacement extends Primitive { + pf_array_displacement() + { + super(Symbol.ARRAY_DISPLACEMENT, "array"); + } + @Override public LispObject execute(LispObject arg) { @@ -2164,9 +2534,13 @@ }; // ### array-in-bounds-p array &rest subscripts => generalized-boolean - private static final Primitive ARRAY_IN_BOUNDS_P = - new Primitive(Symbol.ARRAY_IN_BOUNDS_P, "array &rest subscripts") - { + private static final Primitive ARRAY_IN_BOUNDS_P = new pf_array_in_bounds_p(); + private static final class pf_array_in_bounds_p extends Primitive { + pf_array_in_bounds_p() + { + super(Symbol.ARRAY_IN_BOUNDS_P, "array &rest subscripts"); + } + @Override public LispObject execute(LispObject[] args) { @@ -2205,9 +2579,13 @@ }; // ### %array-row-major-index array subscripts => index - private static final Primitive _ARRAY_ROW_MAJOR_INDEX = - new Primitive("%array-row-major-index", PACKAGE_SYS, false) - { + private static final Primitive _ARRAY_ROW_MAJOR_INDEX = new pf__array_row_major_index(); + private static final class pf__array_row_major_index extends Primitive { + pf__array_row_major_index() + { + super("%array-row-major-index", PACKAGE_SYS, false); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -2220,9 +2598,13 @@ }; // ### aref array &rest subscripts => element - private static final Primitive AREF = - new Primitive(Symbol.AREF, "array &rest subscripts") - { + private static final Primitive AREF = new pf_aref(); + private static final class pf_aref extends Primitive { + pf_aref() + { + super(Symbol.AREF, "array &rest subscripts"); + } + @Override public LispObject execute() { @@ -2268,10 +2650,14 @@ }; // ### aset array subscripts new-element => new-element - private static final Primitive ASET = - new Primitive("aset", PACKAGE_SYS, true, - "array subscripts new-element") - { + private static final Primitive ASET = new pf_aset(); + private static final class pf_aset extends Primitive { + pf_aset() + { + super("aset", PACKAGE_SYS, true, + "array subscripts new-element"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -2313,9 +2699,13 @@ }; // ### row-major-aref array index => element - private static final Primitive ROW_MAJOR_AREF = - new Primitive(Symbol.ROW_MAJOR_AREF, "array index") - { + private static final Primitive ROW_MAJOR_AREF = new pf_row_major_aref(); + private static final class pf_row_major_aref extends Primitive { + pf_row_major_aref() + { + super(Symbol.ROW_MAJOR_AREF, "array index"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -2325,9 +2715,13 @@ }; // ### vector - private static final Primitive VECTOR = - new Primitive(Symbol.VECTOR, "&rest objects") - { + private static final Primitive VECTOR = new pf_vector(); + private static final class pf_vector extends Primitive { + pf_vector() + { + super(Symbol.VECTOR, "&rest objects"); + } + @Override public LispObject execute(LispObject[] args) { @@ -2336,9 +2730,13 @@ }; // ### fill-pointer - private static final Primitive FILL_POINTER = - new Primitive(Symbol.FILL_POINTER, "vector") - { + private static final Primitive FILL_POINTER = new pf_fill_pointer(); + private static final class pf_fill_pointer extends Primitive { + pf_fill_pointer() + { + super(Symbol.FILL_POINTER, "vector"); + } + @Override public LispObject execute(LispObject arg) @@ -2355,9 +2753,13 @@ }; // ### %set-fill-pointer vector new-fill-pointer - private static final Primitive _SET_FILL_POINTER = - new Primitive("%set-fill-pointer", PACKAGE_SYS, true) - { + private static final Primitive _SET_FILL_POINTER = new pf__set_fill_pointer(); + private static final class pf__set_fill_pointer extends Primitive { + pf__set_fill_pointer() + { + super("%set-fill-pointer", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -2379,9 +2781,13 @@ }; // ### vector-push new-element vector => index-of-new-element - private static final Primitive VECTOR_PUSH = - new Primitive(Symbol.VECTOR_PUSH, "new-element vector") - { + private static final Primitive VECTOR_PUSH = new pf_vector_push(); + private static final class pf_vector_push extends Primitive { + pf_vector_push() + { + super(Symbol.VECTOR_PUSH, "new-element vector"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -2400,10 +2806,14 @@ // ### vector-push-extend new-element vector &optional extension // => index-of-new-element - private static final Primitive VECTOR_PUSH_EXTEND = - new Primitive(Symbol.VECTOR_PUSH_EXTEND, - "new-element vector &optional extension") - { + private static final Primitive VECTOR_PUSH_EXTEND = new pf_vector_push_extend(); + private static final class pf_vector_push_extend extends Primitive { + pf_vector_push_extend() + { + super(Symbol.VECTOR_PUSH_EXTEND, + "new-element vector &optional extension"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -2421,9 +2831,13 @@ }; // ### vector-pop vector => element - private static final Primitive VECTOR_POP = - new Primitive(Symbol.VECTOR_POP, "vector") - { + private static final Primitive VECTOR_POP = new pf_vector_pop(); + private static final class pf_vector_pop extends Primitive { + pf_vector_pop() + { + super(Symbol.VECTOR_POP, "vector"); + } + @Override public LispObject execute(LispObject arg) { @@ -2441,9 +2855,13 @@ }; // ### type-of - private static final Primitive TYPE_OF = - new Primitive(Symbol.TYPE_OF, "object") - { + private static final Primitive TYPE_OF = new pf_type_of(); + private static final class pf_type_of extends Primitive { + pf_type_of() + { + super(Symbol.TYPE_OF, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -2452,9 +2870,13 @@ }; // ### class-of - private static final Primitive CLASS_OF = - new Primitive(Symbol.CLASS_OF, "object") - { + private static final Primitive CLASS_OF = new pf_class_of(); + private static final class pf_class_of extends Primitive { + pf_class_of() + { + super(Symbol.CLASS_OF, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -2463,9 +2885,13 @@ }; // ### simple-typep - private static final Primitive SIMPLE_TYPEP = - new Primitive("simple-typep", PACKAGE_SYS, true) - { + private static final Primitive SIMPLE_TYPEP = new pf_simple_typep(); + private static final class pf_simple_typep extends Primitive { + pf_simple_typep() + { + super("simple-typep", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -2476,9 +2902,13 @@ // ### function-lambda-expression function => // lambda-expression, closure-p, name - private static final Primitive FUNCTION_LAMBDA_EXPRESSION = - new Primitive(Symbol.FUNCTION_LAMBDA_EXPRESSION, "function") - { + private static final Primitive FUNCTION_LAMBDA_EXPRESSION = new pf_function_lambda_expression(); + private static final class pf_function_lambda_expression extends Primitive { + pf_function_lambda_expression() + { + super(Symbol.FUNCTION_LAMBDA_EXPRESSION, "function"); + } + @Override public LispObject execute(LispObject arg) { @@ -2525,9 +2955,13 @@ // ### funcall // This needs to be public for LispAPI.java. - public static final Primitive FUNCALL = - new Primitive(Symbol.FUNCALL, "function &rest args") - { + public static final Primitive FUNCALL = new pf_funcall(); + private static final class pf_funcall extends Primitive { + pf_funcall() + { + super(Symbol.FUNCALL, "function &rest args"); + } + @Override public LispObject execute() { @@ -2621,9 +3055,13 @@ }; // ### apply - public static final Primitive APPLY = - new Primitive(Symbol.APPLY, "function &rest args") - { + public static final Primitive APPLY = new pf_apply(); + private static final class pf_apply extends Primitive { + pf_apply() + { + super(Symbol.APPLY, "function &rest args"); + } + @Override public LispObject execute() { @@ -2711,9 +3149,13 @@ }; // ### mapcar - private static final Primitive MAPCAR = - new Primitive(Symbol.MAPCAR, "function &rest lists") - { + private static final Primitive MAPCAR = new pf_mapcar(); + private static final class pf_mapcar extends Primitive { + pf_mapcar() + { + super(Symbol.MAPCAR, "function &rest lists"); + } + @Override public LispObject execute(LispObject fun, LispObject list) @@ -2813,9 +3255,13 @@ }; // ### mapc - private static final Primitive MAPC = - new Primitive(Symbol.MAPC, "function &rest lists") - { + private static final Primitive MAPC = new pf_mapc(); + private static final class pf_mapc extends Primitive { + pf_mapc() + { + super(Symbol.MAPC, "function &rest lists"); + } + @Override public LispObject execute(LispObject fun, LispObject list) @@ -2887,9 +3333,13 @@ }; // ### macroexpand - private static final Primitive MACROEXPAND = - new Primitive(Symbol.MACROEXPAND, "form &optional env") - { + private static final Primitive MACROEXPAND = new pf_macroexpand(); + private static final class pf_macroexpand extends Primitive { + pf_macroexpand() + { + super(Symbol.MACROEXPAND, "form &optional env"); + } + @Override public LispObject execute(LispObject form) { @@ -2908,9 +3358,13 @@ }; // ### macroexpand-1 - private static final Primitive MACROEXPAND_1 = - new Primitive(Symbol.MACROEXPAND_1, "form &optional env") - { + private static final Primitive MACROEXPAND_1 = new pf_macroexpand_1(); + private static final class pf_macroexpand_1 extends Primitive { + pf_macroexpand_1() + { + super(Symbol.MACROEXPAND_1, "form &optional env"); + } + @Override public LispObject execute(LispObject form) { @@ -2929,9 +3383,13 @@ }; // ### gensym - private static final Primitive GENSYM = - new Primitive(Symbol.GENSYM, "&optional x") - { + private static final Primitive GENSYM = new pf_gensym(); + private static final class pf_gensym extends Primitive { + pf_gensym() + { + super(Symbol.GENSYM, "&optional x"); + } + @Override public LispObject execute() { @@ -2970,8 +3428,13 @@ }; // ### string - private static final Primitive STRING = new Primitive(Symbol.STRING, "x") - { + private static final Primitive STRING = new pf_string(); + private static final class pf_string extends Primitive { + pf_string() + { + super(Symbol.STRING, "x"); + } + @Override public LispObject execute(LispObject arg) { @@ -2983,9 +3446,13 @@ // STATUS is one of :INHERITED, :EXTERNAL, :INTERNAL or NIL. // "It is implementation-dependent whether the string that becomes the new // symbol's name is the given string or a copy of it." - private static final Primitive INTERN = - new Primitive(Symbol.INTERN, "string &optional package") - { + private static final Primitive INTERN = new pf_intern(); + private static final class pf_intern extends Primitive { + pf_intern() + { + super(Symbol.INTERN, "string &optional package"); + } + @Override public LispObject execute(LispObject arg) { @@ -3014,9 +3481,13 @@ // ### unintern // unintern symbol &optional package => generalized-boolean - private static final Primitive UNINTERN = - new Primitive(Symbol.UNINTERN, "symbol &optional package") - { + private static final Primitive UNINTERN = new pf_unintern(); + private static final class pf_unintern extends Primitive { + pf_unintern() + { + super(Symbol.UNINTERN, "symbol &optional package"); + } + @Override public LispObject execute(LispObject[] args) { @@ -3033,9 +3504,13 @@ }; // ### find-package - private static final Primitive FIND_PACKAGE = - new Primitive(Symbol.FIND_PACKAGE, "name") - { + private static final Primitive FIND_PACKAGE = new pf_find_package(); + private static final class pf_find_package extends Primitive { + pf_find_package() + { + super(Symbol.FIND_PACKAGE, "name"); + } + @Override public LispObject execute(LispObject arg) { @@ -3065,9 +3540,13 @@ // ### %make-package // %make-package package-name nicknames use => package - private static final Primitive _MAKE_PACKAGE = - new Primitive("%make-package", PACKAGE_SYS, false) - { + private static final Primitive _MAKE_PACKAGE = new pf__make_package(); + private static final class pf__make_package extends Primitive { + pf__make_package() + { + super("%make-package", PACKAGE_SYS, false); + } + /** * This invocation is solely used to be able to create * a package to bind to *FASL-ANONYMOUS-PACKAGE* @@ -3164,9 +3643,13 @@ }; // ### %in-package - private static final Primitive _IN_PACKAGE = - new Primitive("%in-package", PACKAGE_SYS, true) - { + private static final Primitive _IN_PACKAGE = new pf__in_package(); + private static final class pf__in_package extends Primitive { + pf__in_package() + { + super("%in-package", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject arg) { @@ -3187,9 +3670,13 @@ }; // ### use-package packages-to-use &optional package => t - private static final Primitive USE_PACKAGE = - new Primitive(Symbol.USE_PACKAGE, "packages-to-use &optional package") - { + private static final Primitive USE_PACKAGE = new pf_use_package(); + private static final class pf_use_package extends Primitive { + pf_use_package() + { + super(Symbol.USE_PACKAGE, "packages-to-use &optional package"); + } + @Override public LispObject execute(LispObject[] args) { @@ -3216,9 +3703,13 @@ }; // ### package-symbols - private static final Primitive PACKAGE_SYMBOLS = - new Primitive("package-symbols", PACKAGE_SYS, true) - { + private static final Primitive PACKAGE_SYMBOLS = new pf_package_symbols(); + private static final class pf_package_symbols extends Primitive { + pf_package_symbols() + { + super("package-symbols", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject arg) { @@ -3227,9 +3718,13 @@ }; // ### package-internal-symbols - private static final Primitive PACKAGE_INTERNAL_SYMBOLS = - new Primitive("package-internal-symbols", PACKAGE_SYS, true) - { + private static final Primitive PACKAGE_INTERNAL_SYMBOLS = new pf_package_internal_symbols(); + private static final class pf_package_internal_symbols extends Primitive { + pf_package_internal_symbols() + { + super("package-internal-symbols", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject arg) { @@ -3238,9 +3733,13 @@ }; // ### package-external-symbols - private static final Primitive PACKAGE_EXTERNAL_SYMBOLS = - new Primitive("package-external-symbols", PACKAGE_SYS, true) - { + private static final Primitive PACKAGE_EXTERNAL_SYMBOLS = new pf_package_external_symbols(); + private static final class pf_package_external_symbols extends Primitive { + pf_package_external_symbols() + { + super("package-external-symbols", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject arg) { @@ -3249,9 +3748,13 @@ }; // ### package-inherited-symbols - private static final Primitive PACKAGE_INHERITED_SYMBOLS = - new Primitive("package-inherited-symbols", PACKAGE_SYS, true) - { + private static final Primitive PACKAGE_INHERITED_SYMBOLS = new pf_package_inherited_symbols(); + private static final class pf_package_inherited_symbols extends Primitive { + pf_package_inherited_symbols() + { + super("package-inherited-symbols", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject arg) { @@ -3260,9 +3763,13 @@ }; // ### export symbols &optional package - private static final Primitive EXPORT = - new Primitive(Symbol.EXPORT, "symbols &optional package") - { + private static final Primitive EXPORT = new pf_export(); + private static final class pf_export extends Primitive { + pf_export() + { + super(Symbol.EXPORT, "symbols &optional package"); + } + @Override public LispObject execute(LispObject arg) { @@ -3294,9 +3801,13 @@ }; // ### find-symbol string &optional package => symbol, status - private static final Primitive FIND_SYMBOL = - new Primitive(Symbol.FIND_SYMBOL, "string &optional package") - { + private static final Primitive FIND_SYMBOL = new pf_find_symbol(); + private static final class pf_find_symbol extends Primitive { + pf_find_symbol() + { + super(Symbol.FIND_SYMBOL, "string &optional package"); + } + @Override public LispObject execute(LispObject arg) { @@ -3315,9 +3826,13 @@ // ### fset name function &optional source-position arglist documentation // => function - private static final Primitive FSET = - new Primitive("fset", PACKAGE_SYS, true) - { + private static final Primitive FSET = new pf_fset(); + private static final class pf_fset extends Primitive { + pf_fset() + { + super("fset", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -3384,9 +3899,13 @@ }; // ### %set-symbol-plist - private static final Primitive _SET_SYMBOL_PLIST = - new Primitive("%set-symbol-plist", PACKAGE_SYS, false) - { + private static final Primitive _SET_SYMBOL_PLIST = new pf__set_symbol_plist(); + private static final class pf__set_symbol_plist extends Primitive { + pf__set_symbol_plist() + { + super("%set-symbol-plist", PACKAGE_SYS, false); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -3397,9 +3916,13 @@ }; // ### getf plist indicator &optional default => value - private static final Primitive GETF = - new Primitive(Symbol.GETF, "plist indicator &optional default") - { + private static final Primitive GETF = new pf_getf(); + private static final class pf_getf extends Primitive { + pf_getf() + { + super(Symbol.GETF, "plist indicator &optional default"); + } + @Override public LispObject execute(LispObject plist, LispObject indicator) @@ -3416,9 +3939,13 @@ }; // ### get symbol indicator &optional default => value - private static final Primitive GET = - new Primitive(Symbol.GET, "symbol indicator &optional default") - { + private static final Primitive GET = new pf_get(); + private static final class pf_get extends Primitive { + pf_get() + { + super(Symbol.GET, "symbol indicator &optional default"); + } + @Override public LispObject execute(LispObject symbol, LispObject indicator) @@ -3435,9 +3962,13 @@ }; // ### put symbol indicator value => value - private static final Primitive PUT = - new Primitive("put", PACKAGE_SYS, true) - { + private static final Primitive PUT = new pf_put(); + private static final class pf_put extends Primitive { + pf_put() + { + super("put", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject symbol, LispObject indicator, LispObject value) @@ -3492,10 +4023,14 @@ } }; - private static final Primitive MAKE_EXPANDER_FOR_MACROLET = - new Primitive("make-expander-for-macrolet", PACKAGE_SYS, true, - "definition") - { + private static final Primitive MAKE_EXPANDER_FOR_MACROLET = new pf_make_expander_for_macrolet(); + private static final class pf_make_expander_for_macrolet extends Primitive { + pf_make_expander_for_macrolet() + { + super("make-expander-for-macrolet", PACKAGE_SYS, true, + "definition"); + } + @Override public LispObject execute(LispObject definition) @@ -3994,9 +4529,13 @@ }; // ### call-count - private static final Primitive CALL_COUNT = - new Primitive("call-count", PACKAGE_SYS, true) - { + private static final Primitive CALL_COUNT = new pf_call_count(); + private static final class pf_call_count extends Primitive { + pf_call_count() + { + super("call-count", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject arg) { @@ -4005,9 +4544,13 @@ }; // ### set-call-count - private static final Primitive SET_CALL_COUNT = - new Primitive("set-call-count", PACKAGE_SYS, true) - { + private static final Primitive SET_CALL_COUNT = new pf_set_call_count(); + private static final class pf_set_call_count extends Primitive { + pf_set_call_count() + { + super("set-call-count", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -4018,9 +4561,13 @@ }; // ### call-count - private static final Primitive HOT_COUNT = - new Primitive("hot-count", PACKAGE_SYS, true) - { + private static final Primitive HOT_COUNT = new pf_hot_count(); + private static final class pf_hot_count extends Primitive { + pf_hot_count() + { + super("hot-count", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject arg) { @@ -4029,9 +4576,13 @@ }; // ### set-call-count - private static final Primitive SET_HOT_COUNT = - new Primitive("set-hot-count", PACKAGE_SYS, true) - { + private static final Primitive SET_HOT_COUNT = new pf_set_hot_count(); + private static final class pf_set_hot_count extends Primitive { + pf_set_hot_count() + { + super("set-hot-count", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -4042,9 +4593,13 @@ }; // ### lambda-name - private static final Primitive LAMBDA_NAME = - new Primitive("lambda-name", PACKAGE_SYS, true) - { + private static final Primitive LAMBDA_NAME = new pf_lambda_name(); + private static final class pf_lambda_name extends Primitive { + pf_lambda_name() + { + super("lambda-name", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject arg) { @@ -4061,9 +4616,13 @@ }; // ### %set-lambda-name - private static final Primitive _SET_LAMBDA_NAME = - new Primitive("%set-lambda-name", PACKAGE_SYS, false) - { + private static final Primitive _SET_LAMBDA_NAME = new pf__set_lambda_name(); + private static final class pf__set_lambda_name extends Primitive { + pf__set_lambda_name() + { + super("%set-lambda-name", PACKAGE_SYS, false); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -4086,9 +4645,13 @@ // Destructively alters the vector, changing its length to NEW-SIZE, which // must be less than or equal to its current length. // shrink-vector vector new-size => vector - private static final Primitive SHRINK_VECTOR = - new Primitive("shrink-vector", PACKAGE_SYS, true, "vector new-size") - { + private static final Primitive SHRINK_VECTOR = new pf_shrink_vector(); + private static final class pf_shrink_vector extends Primitive { + pf_shrink_vector() + { + super("shrink-vector", PACKAGE_SYS, true, "vector new-size"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -4099,9 +4662,13 @@ }; // ### subseq sequence start &optional end - private static final Primitive SUBSEQ = - new Primitive(Symbol.SUBSEQ, "sequence start &optional end") - { + private static final Primitive SUBSEQ = new pf_subseq(); + private static final class pf_subseq extends Primitive { + pf_subseq() + { + super(Symbol.SUBSEQ, "sequence start &optional end"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -4183,9 +4750,13 @@ } // ### list - private static final Primitive LIST = - new Primitive(Symbol.LIST, "&rest objects") - { + private static final Primitive LIST = new pf_list(); + private static final class pf_list extends Primitive { + pf_list() + { + super(Symbol.LIST, "&rest objects"); + } + @Override public LispObject execute() { @@ -4227,9 +4798,13 @@ }; // ### list* - private static final Primitive LIST_STAR = - new Primitive(Symbol.LIST_STAR, "&rest objects") - { + private static final Primitive LIST_STAR = new pf_list_star(); + private static final class pf_list_star extends Primitive { + pf_list_star() + { + super(Symbol.LIST_STAR, "&rest objects"); + } + @Override public LispObject execute() { @@ -4274,9 +4849,13 @@ }; // ### nreverse - public static final Primitive NREVERSE = - new Primitive(Symbol.NREVERSE, "sequence") - { + public static final Primitive NREVERSE = new pf_nreverse(); + private static final class pf_nreverse extends Primitive { + pf_nreverse() + { + super(Symbol.NREVERSE, "sequence"); + } + @Override public LispObject execute (LispObject arg) { @@ -4285,9 +4864,13 @@ }; // ### nreconc - private static final Primitive NRECONC = - new Primitive(Symbol.NRECONC, "list tail") - { + private static final Primitive NRECONC = new pf_nreconc(); + private static final class pf_nreconc extends Primitive { + pf_nreconc() + { + super(Symbol.NRECONC, "list tail"); + } + @Override public LispObject execute(LispObject list, LispObject obj) @@ -4332,9 +4915,13 @@ }; // ### reverse - private static final Primitive REVERSE = - new Primitive(Symbol.REVERSE, "sequence") - { + private static final Primitive REVERSE = new pf_reverse(); + private static final class pf_reverse extends Primitive { + pf_reverse() + { + super(Symbol.REVERSE, "sequence"); + } + @Override public LispObject execute(LispObject arg) { @@ -4343,9 +4930,13 @@ }; // ### delete-eq item sequence => result-sequence - private static final Primitive DELETE_EQ = - new Primitive("delete-eq", PACKAGE_SYS, true, "item sequence") - { + private static final Primitive DELETE_EQ = new pf_delete_eq(); + private static final class pf_delete_eq extends Primitive { + pf_delete_eq() + { + super("delete-eq", PACKAGE_SYS, true, "item sequence"); + } + @Override public LispObject execute(LispObject item, LispObject sequence) @@ -4358,9 +4949,13 @@ }; // ### delete-eql item seqluence => result-seqluence - private static final Primitive DELETE_EQL = - new Primitive("delete-eql", PACKAGE_SYS, true, "item sequence") - { + private static final Primitive DELETE_EQL = new pf_delete_eql(); + private static final class pf_delete_eql extends Primitive { + pf_delete_eql() + { + super("delete-eql", PACKAGE_SYS, true, "item sequence"); + } + @Override public LispObject execute(LispObject item, LispObject sequence) @@ -4373,9 +4968,13 @@ }; // ### list-delete-eq item list => result-list - private static final Primitive LIST_DELETE_EQ = - new Primitive("list-delete-eq", PACKAGE_SYS, true, "item list") - { + private static final Primitive LIST_DELETE_EQ = new pf_list_delete_eq(); + private static final class pf_list_delete_eq extends Primitive { + pf_list_delete_eq() + { + super("list-delete-eq", PACKAGE_SYS, true, "item list"); + } + @Override public LispObject execute(LispObject item, LispObject list) @@ -4423,9 +5022,13 @@ }; // ### list-delete-eql item list => result-list - private static final Primitive LIST_DELETE_EQL = - new Primitive("list-delete-eql", PACKAGE_SYS, true, "item list") - { + private static final Primitive LIST_DELETE_EQL = new pf_list_delete_eql(); + private static final class pf_list_delete_eql extends Primitive { + pf_list_delete_eql() + { + super("list-delete-eql", PACKAGE_SYS, true, "item list"); + } + @Override public LispObject execute(LispObject item, LispObject list) @@ -4473,9 +5076,13 @@ }; // ### vector-delete-eq item vector => result-vector - private static final Primitive VECTOR_DELETE_EQ = - new Primitive("vector-delete-eq", PACKAGE_SYS, true, "item vector") - { + private static final Primitive VECTOR_DELETE_EQ = new pf_vector_delete_eq(); + private static final class pf_vector_delete_eq extends Primitive { + pf_vector_delete_eq() + { + super("vector-delete-eq", PACKAGE_SYS, true, "item vector"); + } + @Override public LispObject execute(LispObject item, LispObject vector) @@ -4486,9 +5093,13 @@ }; // ### vector-delete-eql item vector => result-vector - private static final Primitive VECTOR_DELETE_EQL = - new Primitive("vector-delete-eql", PACKAGE_SYS, true, "item vector") - { + private static final Primitive VECTOR_DELETE_EQL = new pf_vector_delete_eql(); + private static final class pf_vector_delete_eql extends Primitive { + pf_vector_delete_eql() + { + super("vector-delete-eql", PACKAGE_SYS, true, "item vector"); + } + @Override public LispObject execute(LispObject item, LispObject vector) @@ -4500,9 +5111,13 @@ // ### %set-elt // %setelt sequence index newval => newval - private static final Primitive _SET_ELT = - new Primitive("%set-elt", PACKAGE_SYS, false) - { + private static final Primitive _SET_ELT = new pf__set_elt(); + private static final class pf__set_elt extends Primitive { + pf__set_elt() + { + super("%set-elt", PACKAGE_SYS, false); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) @@ -4538,9 +5153,13 @@ }; // ### %make-list - private static final Primitive _MAKE_LIST = - new Primitive("%make-list", PACKAGE_SYS, true) - { + private static final Primitive _MAKE_LIST = new pf__make_list(); + private static final class pf__make_list extends Primitive { + pf__make_list() + { + super("%make-list", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -4557,9 +5176,13 @@ }; // ### %member item list key test test-not => tail - private static final Primitive _MEMBER = - new Primitive("%member", PACKAGE_SYS, true) - { + private static final Primitive _MEMBER = new pf__member(); + private static final class pf__member extends Primitive { + pf__member() + { + super("%member", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject item, LispObject list, LispObject key, LispObject test, @@ -4633,9 +5256,13 @@ }; // ### funcall-key function-or-nil element - private static final Primitive FUNCALL_KEY = - new Primitive("funcall-key", PACKAGE_SYS, false) - { + private static final Primitive FUNCALL_KEY = new pf_funcall_key(); + private static final class pf_funcall_key extends Primitive { + pf_funcall_key() + { + super("funcall-key", PACKAGE_SYS, false); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -4647,9 +5274,13 @@ }; // ### coerce-to-function - private static final Primitive COERCE_TO_FUNCTION = - new Primitive("coerce-to-function", PACKAGE_SYS, true) - { + private static final Primitive COERCE_TO_FUNCTION = new pf_coerce_to_function(); + private static final class pf_coerce_to_function extends Primitive { + pf_coerce_to_function() + { + super("coerce-to-function", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject arg) { @@ -4658,9 +5289,13 @@ }; // ### make-closure lambda-form environment => closure - private static final Primitive MAKE_CLOSURE = - new Primitive("make-closure", PACKAGE_SYS, true) - { + private static final Primitive MAKE_CLOSURE = new pf_make_closure(); + private static final class pf_make_closure extends Primitive { + pf_make_closure() + { + super("make-closure", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -4679,9 +5314,13 @@ }; // ### streamp - private static final Primitive STREAMP = - new Primitive(Symbol.STREAMP, "object") - { + private static final Primitive STREAMP = new pf_streamp(); + private static final class pf_streamp extends Primitive { + pf_streamp() + { + super(Symbol.STREAMP, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -4690,9 +5329,13 @@ }; // ### integerp - private static final Primitive INTEGERP = - new Primitive(Symbol.INTEGERP, "object") - { + private static final Primitive INTEGERP = new pf_integerp(); + private static final class pf_integerp extends Primitive { + pf_integerp() + { + super(Symbol.INTEGERP, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -4701,9 +5344,13 @@ }; // ### evenp - private static final Primitive EVENP = - new Primitive(Symbol.EVENP, "integer") - { + private static final Primitive EVENP = new pf_evenp(); + private static final class pf_evenp extends Primitive { + pf_evenp() + { + super(Symbol.EVENP, "integer"); + } + @Override public LispObject execute(LispObject arg) { @@ -4712,8 +5359,13 @@ }; // ### oddp - private static final Primitive ODDP = new Primitive(Symbol.ODDP, "integer") - { + private static final Primitive ODDP = new pf_oddp(); + private static final class pf_oddp extends Primitive { + pf_oddp() + { + super(Symbol.ODDP, "integer"); + } + @Override public LispObject execute(LispObject arg) { @@ -4722,9 +5374,13 @@ }; // ### numberp - private static final Primitive NUMBERP = - new Primitive(Symbol.NUMBERP, "object") - { + private static final Primitive NUMBERP = new pf_numberp(); + private static final class pf_numberp extends Primitive { + pf_numberp() + { + super(Symbol.NUMBERP, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -4733,9 +5389,13 @@ }; // ### realp - private static final Primitive REALP = - new Primitive(Symbol.REALP, "object") - { + private static final Primitive REALP = new pf_realp(); + private static final class pf_realp extends Primitive { + pf_realp() + { + super(Symbol.REALP, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -4744,9 +5404,13 @@ }; // ### rationalp - private static final Primitive RATIONALP = - new Primitive(Symbol.RATIONALP,"object") - { + private static final Primitive RATIONALP = new pf_rationalp(); + private static final class pf_rationalp extends Primitive { + pf_rationalp() + { + super(Symbol.RATIONALP,"object"); + } + @Override public LispObject execute(LispObject arg) { @@ -4755,9 +5419,13 @@ }; // ### complex - private static final Primitive COMPLEX = - new Primitive(Symbol.COMPLEX, "realpart &optional imagpart") - { + private static final Primitive COMPLEX = new pf_complex(); + private static final class pf_complex extends Primitive { + pf_complex() + { + super(Symbol.COMPLEX, "realpart &optional imagpart"); + } + @Override public LispObject execute(LispObject arg) { @@ -4778,9 +5446,13 @@ }; // ### complexp - private static final Primitive COMPLEXP = - new Primitive(Symbol.COMPLEXP, "object") - { + private static final Primitive COMPLEXP = new pf_complexp(); + private static final class pf_complexp extends Primitive { + pf_complexp() + { + super(Symbol.COMPLEXP, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -4789,9 +5461,13 @@ }; // ### numerator - private static final Primitive NUMERATOR = - new Primitive(Symbol.NUMERATOR, "rational") - { + private static final Primitive NUMERATOR = new pf_numerator(); + private static final class pf_numerator extends Primitive { + pf_numerator() + { + super(Symbol.NUMERATOR, "rational"); + } + @Override public LispObject execute(LispObject arg) { @@ -4800,9 +5476,13 @@ }; // ### denominator - private static final Primitive DENOMINATOR = - new Primitive(Symbol.DENOMINATOR, "rational") - { + private static final Primitive DENOMINATOR = new pf_denominator(); + private static final class pf_denominator extends Primitive { + pf_denominator() + { + super(Symbol.DENOMINATOR, "rational"); + } + @Override public LispObject execute(LispObject arg) { @@ -4811,9 +5491,13 @@ }; // ### realpart - private static final Primitive REALPART = - new Primitive(Symbol.REALPART, "number") - { + private static final Primitive REALPART = new pf_realpart(); + private static final class pf_realpart extends Primitive { + pf_realpart() + { + super(Symbol.REALPART, "number"); + } + @Override public LispObject execute(LispObject arg) { @@ -4826,9 +5510,13 @@ }; // ### imagpart - private static final Primitive IMAGPART = - new Primitive(Symbol.IMAGPART, "number") - { + private static final Primitive IMAGPART = new pf_imagpart(); + private static final class pf_imagpart extends Primitive { + pf_imagpart() + { + super(Symbol.IMAGPART, "number"); + } + @Override public LispObject execute(LispObject arg) { @@ -4839,9 +5527,13 @@ }; // ### integer-length - private static final Primitive INTEGER_LENGTH = - new Primitive(Symbol.INTEGER_LENGTH, "integer") - { + private static final Primitive INTEGER_LENGTH = new pf_integer_length(); + private static final class pf_integer_length extends Primitive { + pf_integer_length() + { + super(Symbol.INTEGER_LENGTH, "integer"); + } + @Override public LispObject execute(LispObject arg) { @@ -4865,9 +5557,13 @@ }; // ### gcd-2 - private static final Primitive GCD_2 = - new Primitive("gcd-2", PACKAGE_SYS, false) - { + private static final Primitive GCD_2 = new pf_gcd_2(); + private static final class pf_gcd_2 extends Primitive { + pf_gcd_2() + { + super("gcd-2", PACKAGE_SYS, false); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -4890,9 +5586,13 @@ }; // ### identity-hash-code - private static final Primitive IDENTITY_HASH_CODE = - new Primitive("identity-hash-code", PACKAGE_SYS, true) - { + private static final Primitive IDENTITY_HASH_CODE = new pf_identity_hash_code(); + private static final class pf_identity_hash_code extends Primitive { + pf_identity_hash_code() + { + super("identity-hash-code", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject arg) { @@ -4902,9 +5602,13 @@ // ### simple-vector-search pattern vector => position // Searches vector for pattern. - private static final Primitive SIMPLE_VECTOR_SEARCH = - new Primitive("simple-vector-search", PACKAGE_SYS, false) - { + private static final Primitive SIMPLE_VECTOR_SEARCH = new pf_simple_vector_search(); + private static final class pf_simple_vector_search extends Primitive { + pf_simple_vector_search() + { + super("simple-vector-search", PACKAGE_SYS, false); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -4977,9 +5681,13 @@ }; // ### uptime - private static final Primitive UPTIME = - new Primitive("uptime", PACKAGE_EXT, true) - { + private static final Primitive UPTIME = new pf_uptime(); + private static final class pf_uptime extends Primitive { + pf_uptime() + { + super("uptime", PACKAGE_EXT, true); + } + @Override public LispObject execute() { @@ -4988,9 +5696,13 @@ }; // ### built-in-function-p - private static final Primitive BUILT_IN_FUNCTION_P = - new Primitive("built-in-function-p", PACKAGE_SYS, true) - { + private static final Primitive BUILT_IN_FUNCTION_P = new pf_built_in_function_p(); + private static final class pf_built_in_function_p extends Primitive { + pf_built_in_function_p() + { + super("built-in-function-p", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject arg) { @@ -4999,9 +5711,13 @@ }; // ### inspected-parts - private static final Primitive INSPECTED_PARTS = - new Primitive("inspected-parts", PACKAGE_SYS, true) - { + private static final Primitive INSPECTED_PARTS = new pf_inspected_parts(); + private static final class pf_inspected_parts extends Primitive { + pf_inspected_parts() + { + super("inspected-parts", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject arg) { @@ -5010,9 +5726,13 @@ }; // ### inspected-description - private static final Primitive INSPECTED_DESCRIPTION = - new Primitive("inspected-description", PACKAGE_SYS, false) - { + private static final Primitive INSPECTED_DESCRIPTION = new pf_inspected_description(); + private static final class pf_inspected_description extends Primitive { + pf_inspected_description() + { + super("inspected-description", PACKAGE_SYS, false); + } + @Override public LispObject execute(LispObject arg) { @@ -5021,9 +5741,13 @@ }; // ### symbol-name - public static final Primitive SYMBOL_NAME = - new Primitive(Symbol.SYMBOL_NAME, "symbol") - { + public static final Primitive SYMBOL_NAME = new pf_symbol_name(); + private static final class pf_symbol_name extends Primitive { + pf_symbol_name() + { + super(Symbol.SYMBOL_NAME, "symbol"); + } + @Override public LispObject execute(LispObject arg) { @@ -5032,9 +5756,13 @@ }; // ### symbol-package - public static final Primitive SYMBOL_PACKAGE = - new Primitive(Symbol.SYMBOL_PACKAGE, "symbol") - { + public static final Primitive SYMBOL_PACKAGE = new pf_symbol_package(); + private static final class pf_symbol_package extends Primitive { + pf_symbol_package() + { + super(Symbol.SYMBOL_PACKAGE, "symbol"); + } + @Override public LispObject execute(LispObject arg) { @@ -5043,9 +5771,13 @@ }; // ### symbol-function - public static final Primitive SYMBOL_FUNCTION = - new Primitive(Symbol.SYMBOL_FUNCTION, "symbol") - { + public static final Primitive SYMBOL_FUNCTION = new pf_symbol_function(); + private static final class pf_symbol_function extends Primitive { + pf_symbol_function() + { + super(Symbol.SYMBOL_FUNCTION, "symbol"); + } + @Override public LispObject execute(LispObject arg) { @@ -5058,9 +5790,13 @@ }; // ### %set-symbol-function - public static final Primitive _SET_SYMBOL_FUNCTION = - new Primitive("%set-symbol-function", PACKAGE_SYS, false, "symbol function") - { + public static final Primitive _SET_SYMBOL_FUNCTION = new pf__set_symbol_function(); + private static final class pf__set_symbol_function extends Primitive { + pf__set_symbol_function() + { + super("%set-symbol-function", PACKAGE_SYS, false, "symbol function"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -5071,9 +5807,13 @@ }; // ### symbol-plist - public static final Primitive SYMBOL_PLIST = - new Primitive(Symbol.SYMBOL_PLIST, "symbol") - { + public static final Primitive SYMBOL_PLIST = new pf_symbol_plist(); + private static final class pf_symbol_plist extends Primitive { + pf_symbol_plist() + { + super(Symbol.SYMBOL_PLIST, "symbol"); + } + @Override public LispObject execute(LispObject arg) { @@ -5082,9 +5822,13 @@ }; // ### keywordp - public static final Primitive KEYWORDP = - new Primitive(Symbol.KEYWORDP, "object") - { + public static final Primitive KEYWORDP = new pf_keywordp(); + private static final class pf_keywordp extends Primitive { + pf_keywordp() + { + super(Symbol.KEYWORDP, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -5098,9 +5842,13 @@ }; // ### make-symbol - public static final Primitive MAKE_SYMBOL = - new Primitive(Symbol.MAKE_SYMBOL, "name") - { + public static final Primitive MAKE_SYMBOL = new pf_make_symbol(); + private static final class pf_make_symbol extends Primitive { + pf_make_symbol() + { + super(Symbol.MAKE_SYMBOL, "name"); + } + @Override public LispObject execute(LispObject arg) { @@ -5114,9 +5862,13 @@ }; // ### makunbound - public static final Primitive MAKUNBOUND = - new Primitive(Symbol.MAKUNBOUND, "symbol") - { + public static final Primitive MAKUNBOUND = new pf_makunbound(); + private static final class pf_makunbound extends Primitive { + pf_makunbound() + { + super(Symbol.MAKUNBOUND, "symbol"); + } + @Override public LispObject execute(LispObject arg) { @@ -5126,9 +5878,13 @@ }; // ### %class-name - private static final Primitive _CLASS_NAME = - new Primitive("%class-name", PACKAGE_SYS, true, "class") - { + private static final Primitive _CLASS_NAME = new pf__class_name(); + private static final class pf__class_name extends Primitive { + pf__class_name() + { + super("%class-name", PACKAGE_SYS, true, "class"); + } + @Override public LispObject execute(LispObject arg) { @@ -5137,9 +5893,13 @@ }; // ### %set-class-name - private static final Primitive _SET_CLASS_NAME = - new Primitive("%set-class-name", PACKAGE_SYS, true) - { + private static final Primitive _SET_CLASS_NAME = new pf__set_class_name(); + private static final class pf__set_class_name extends Primitive { + pf__set_class_name() + { + super("%set-class-name", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -5150,9 +5910,13 @@ }; // ### class-layout - private static final Primitive CLASS_LAYOUT = - new Primitive("class-layout", PACKAGE_SYS, true, "class") - { + private static final Primitive CLASS_LAYOUT = new pf_class_layout(); + private static final class pf_class_layout extends Primitive { + pf_class_layout() + { + super("class-layout", PACKAGE_SYS, true, "class"); + } + @Override public LispObject execute(LispObject arg) { @@ -5162,9 +5926,13 @@ }; // ### %set-class-layout - private static final Primitive _SET_CLASS_LAYOUT = - new Primitive("%set-class-layout", PACKAGE_SYS, true, "class layout") - { + private static final Primitive _SET_CLASS_LAYOUT = new pf__set_class_layout(); + private static final class pf__set_class_layout extends Primitive { + pf__set_class_layout() + { + super("%set-class-layout", PACKAGE_SYS, true, "class layout"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -5179,9 +5947,13 @@ }; // ### class-direct-superclasses - private static final Primitive CLASS_DIRECT_SUPERCLASSES = - new Primitive("class-direct-superclasses", PACKAGE_SYS, true) - { + private static final Primitive CLASS_DIRECT_SUPERCLASSES = new pf_class_direct_superclasses(); + private static final class pf_class_direct_superclasses extends Primitive { + pf_class_direct_superclasses() + { + super("class-direct-superclasses", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject arg) { @@ -5190,9 +5962,13 @@ }; // ### %set-class-direct-superclasses - private static final Primitive _SET_CLASS_DIRECT_SUPERCLASSES = - new Primitive("%set-class-direct-superclasses", PACKAGE_SYS, true) - { + private static final Primitive _SET_CLASS_DIRECT_SUPERCLASSES = new pf__set_class_direct_superclasses(); + private static final class pf__set_class_direct_superclasses extends Primitive { + pf__set_class_direct_superclasses() + { + super("%set-class-direct-superclasses", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -5203,9 +5979,13 @@ }; // ### class-direct-subclasses - private static final Primitive CLASS_DIRECT_SUBCLASSES = - new Primitive("class-direct-subclasses", PACKAGE_SYS, true) - { + private static final Primitive CLASS_DIRECT_SUBCLASSES = new pf_class_direct_subclasses(); + private static final class pf_class_direct_subclasses extends Primitive { + pf_class_direct_subclasses() + { + super("class-direct-subclasses", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject arg) { @@ -5214,10 +5994,14 @@ }; // ### %set-class-direct-subclasses - private static final Primitive _SET_CLASS_DIRECT_SUBCLASSES = - new Primitive("%set-class-direct-subclasses", PACKAGE_SYS, true, - "class direct-subclasses") - { + private static final Primitive _SET_CLASS_DIRECT_SUBCLASSES = new pf__set_class_direct_subclasses(); + private static final class pf__set_class_direct_subclasses extends Primitive { + pf__set_class_direct_subclasses() + { + super("%set-class-direct-subclasses", PACKAGE_SYS, true, + "class direct-subclasses"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -5228,9 +6012,13 @@ }; // ### %class-precedence-list - private static final Primitive _CLASS_PRECEDENCE_LIST = - new Primitive("%class-precedence-list", PACKAGE_SYS, true) - { + private static final Primitive _CLASS_PRECEDENCE_LIST = new pf__class_precedence_list(); + private static final class pf__class_precedence_list extends Primitive { + pf__class_precedence_list() + { + super("%class-precedence-list", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject arg) { @@ -5239,9 +6027,13 @@ }; // ### set-class-precedence-list - private static final Primitive SET_CLASS_PRECEDENCE_LIST = - new Primitive("set-class-precedence-list", PACKAGE_SYS, true) - { + private static final Primitive SET_CLASS_PRECEDENCE_LIST = new pf_set_class_precedence_list(); + private static final class pf_set_class_precedence_list extends Primitive { + pf_set_class_precedence_list() + { + super("set-class-precedence-list", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -5252,9 +6044,13 @@ }; // ### class-direct-methods - private static final Primitive CLASS_DIRECT_METHODS = - new Primitive("class-direct-methods", PACKAGE_SYS, true) - { + private static final Primitive CLASS_DIRECT_METHODS = new pf_class_direct_methods(); + private static final class pf_class_direct_methods extends Primitive { + pf_class_direct_methods() + { + super("class-direct-methods", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject arg) @@ -5264,9 +6060,13 @@ }; // ### %set-class-direct-methods - private static final Primitive _SET_CLASS_DIRECT_METHODS = - new Primitive("%set-class-direct-methods", PACKAGE_SYS, true) - { + private static final Primitive _SET_CLASS_DIRECT_METHODS = new pf__set_class_direct_methods(); + private static final class pf__set_class_direct_methods extends Primitive { + pf__set_class_direct_methods() + { + super("%set-class-direct-methods", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -5277,9 +6077,13 @@ }; // ### class-documentation - private static final Primitive CLASS_DOCUMENTATION = - new Primitive("class-documentation", PACKAGE_SYS, true) - { + private static final Primitive CLASS_DOCUMENTATION = new pf_class_documentation(); + private static final class pf_class_documentation extends Primitive { + pf_class_documentation() + { + super("class-documentation", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject arg) @@ -5289,9 +6093,13 @@ }; // ### %set-class-documentation - private static final Primitive _SET_CLASS_DOCUMENTATION = - new Primitive("%set-class-documentation", PACKAGE_SYS, true) - { + private static final Primitive _SET_CLASS_DOCUMENTATION = new pf__set_class_documentation(); + private static final class pf__set_class_documentation extends Primitive { + pf__set_class_documentation() + { + super("%set-class-documentation", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -5302,9 +6110,13 @@ }; // ### class-finalized-p - private static final Primitive CLASS_FINALIZED_P = - new Primitive("class-finalized-p", PACKAGE_SYS, true) - { + private static final Primitive CLASS_FINALIZED_P = new pf_class_finalized_p(); + private static final class pf_class_finalized_p extends Primitive { + pf_class_finalized_p() + { + super("class-finalized-p", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject arg) { @@ -5313,9 +6125,13 @@ }; // ### %set-class-finalized-p - private static final Primitive _SET_CLASS_FINALIZED_P = - new Primitive("%set-class-finalized-p", PACKAGE_SYS, true) - { + private static final Primitive _SET_CLASS_FINALIZED_P = new pf__set_class_finalized_p(); + private static final class pf__set_class_finalized_p extends Primitive { + pf__set_class_finalized_p() + { + super("%set-class-finalized-p", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -5326,9 +6142,13 @@ }; // ### classp - private static final Primitive CLASSP = - new Primitive("classp", PACKAGE_EXT, true) - { + private static final Primitive CLASSP = new pf_classp(); + private static final class pf_classp extends Primitive { + pf_classp() + { + super("classp", PACKAGE_EXT, true); + } + @Override public LispObject execute(LispObject arg) { @@ -5337,9 +6157,13 @@ }; // ### char-to-utf8 char => octets - private static final Primitive CHAR_TO_UTF8 = - new Primitive("char-to-utf8", PACKAGE_EXT, true) - { + private static final Primitive CHAR_TO_UTF8 = new pf_char_to_utf8(); + private static final class pf_char_to_utf8 extends Primitive { + pf_char_to_utf8() + { + super("char-to-utf8", PACKAGE_EXT, true); + } + @Override public LispObject execute(LispObject arg) { @@ -5370,10 +6194,14 @@ }; // ### %documentation - private static final Primitive _DOCUMENTATION = - new Primitive("%documentation", PACKAGE_SYS, true, - "object doc-type") - { + private static final Primitive _DOCUMENTATION = new pf__documentation(); + private static final class pf__documentation extends Primitive { + pf__documentation() + { + super("%documentation", PACKAGE_SYS, true, + "object doc-type"); + } + @Override public LispObject execute(LispObject object, LispObject docType) @@ -5393,10 +6221,14 @@ }; // ### %set-documentation - private static final Primitive _SET_DOCUMENTATION = - new Primitive("%set-documentation", PACKAGE_SYS, true, - "object doc-type documentation") - { + private static final Primitive _SET_DOCUMENTATION = new pf__set_documentation(); + private static final class pf__set_documentation extends Primitive { + pf__set_documentation() + { + super("%set-documentation", PACKAGE_SYS, true, + "object doc-type documentation"); + } + @Override public LispObject execute(LispObject object, LispObject docType, LispObject documentation) @@ -5408,10 +6240,14 @@ }; // ### %putf - private static final Primitive _PUTF = - new Primitive("%putf", PACKAGE_SYS, true, - "plist indicator new-value") - { + private static final Primitive _PUTF = new pf__putf(); + private static final class pf__putf extends Primitive { + pf__putf() + { + super("%putf", PACKAGE_SYS, true, + "plist indicator new-value"); + } + @Override public LispObject execute(LispObject plist, LispObject indicator, LispObject newValue) @@ -5422,9 +6258,13 @@ }; // ### function-plist - private static final Primitive FUNCTION_PLIST = - new Primitive("function-plist", PACKAGE_SYS, true, "function") - { + private static final Primitive FUNCTION_PLIST = new pf_function_plist(); + private static final class pf_function_plist extends Primitive { + pf_function_plist() + { + super("function-plist", PACKAGE_SYS, true, "function"); + } + @Override public LispObject execute(LispObject arg) { @@ -5433,9 +6273,13 @@ }; // ### make-keyword - private static final Primitive MAKE_KEYWORD = - new Primitive("make-keyword", PACKAGE_SYS, true, "symbol") - { + private static final Primitive MAKE_KEYWORD = new pf_make_keyword(); + private static final class pf_make_keyword extends Primitive { + pf_make_keyword() + { + super("make-keyword", PACKAGE_SYS, true, "symbol"); + } + @Override public LispObject execute(LispObject arg) { @@ -5444,9 +6288,13 @@ }; // ### standard-object-p object => generalized-boolean - private static final Primitive STANDARD_OBJECT_P = - new Primitive("standard-object-p", PACKAGE_SYS, true, "object") - { + private static final Primitive STANDARD_OBJECT_P = new pf_standard_object_p(); + private static final class pf_standard_object_p extends Primitive { + pf_standard_object_p() + { + super("standard-object-p", PACKAGE_SYS, true, "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -5455,9 +6303,13 @@ }; // ### copy-tree - private static final Primitive COPY_TREE = - new Primitive(Symbol.COPY_TREE, "object") - { + private static final Primitive COPY_TREE = new pf_copy_tree(); + private static final class pf_copy_tree extends Primitive { + pf_copy_tree() + { + super(Symbol.COPY_TREE, "object"); + } + @Override public LispObject execute(LispObject arg) { From ehuelsmann at common-lisp.net Fri Feb 12 23:54:45 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 12 Feb 2010 18:54:45 -0500 Subject: [armedbear-cvs] r12455 - branches/metaclass/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Feb 12 18:54:42 2010 New Revision: 12455 Log: Make STANDARD-CLASS a normal STANDARD-OBJECT with a normal Layout and normal slots. Of course, that requires some support from its superclasses (SlotClass and LispClass). Modified: branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java Modified: branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java Fri Feb 12 18:54:42 2010 @@ -98,20 +98,24 @@ public LispObject documentation = NIL; // FIXME! Should be private! private boolean finalized; - protected LispClass() + protected LispClass(Layout layout) { + super(layout, layout == null ? 0 : layout.getLength()); sxhash = hashCode() & 0x7fffffff; } - protected LispClass(Symbol symbol) + protected LispClass(Layout layout, Symbol symbol) { + super(layout, layout == null ? 0 : layout.getLength()); sxhash = hashCode() & 0x7fffffff; this.symbol = symbol; this.directSuperclasses = NIL; } - protected LispClass(Symbol symbol, LispObject directSuperclasses) + protected LispClass(Layout layout, + Symbol symbol, LispObject directSuperclasses) { + super(layout, layout == null ? 0 : layout.getLength()); sxhash = hashCode() & 0x7fffffff; this.symbol = symbol; this.directSuperclasses = directSuperclasses; Modified: branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java Fri Feb 12 18:54:42 2010 @@ -42,13 +42,15 @@ private LispObject directDefaultInitargs = NIL; private LispObject defaultInitargs = NIL; - public SlotClass() + public SlotClass(Layout layout) { + super(layout); } - public SlotClass(Symbol symbol, LispObject directSuperclasses) + public SlotClass(Layout layout, + Symbol symbol, LispObject directSuperclasses) { - super(symbol, directSuperclasses); + super(layout, symbol, directSuperclasses); } @Override Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java Fri Feb 12 18:54:42 2010 @@ -37,21 +37,38 @@ public class StandardClass extends SlotClass { + + static Layout layoutStandardClass = + new Layout(null, + list(PACKAGE_MOP.intern("NAME"), + PACKAGE_MOP.intern("LAYOUT"), + PACKAGE_MOP.intern("DIRECT-SUPERCLASSES"), + PACKAGE_MOP.intern("DIRECT-SUBCLASSES"), + PACKAGE_MOP.intern("CLASS-PRECEDENCE-LIST"), + PACKAGE_MOP.intern("DIRECT-METHODS"), + PACKAGE_MOP.intern("DOCUMENTATION"), + PACKAGE_MOP.intern("DIRECT-SLOTS"), + PACKAGE_MOP.intern("SLOTS"), + PACKAGE_MOP.intern("DIRECT-DEFAULT-INITARGS"), + PACKAGE_MOP.intern("DEFAULT-INITARGS")), + NIL) + { + @Override + public LispClass getLispClass() + { + return STANDARD_CLASS; + } + }; + public StandardClass() { - setClassLayout(new Layout(this, NIL, NIL)); + super(layoutStandardClass); } public StandardClass(Symbol symbol, LispObject directSuperclasses) { - super(symbol, directSuperclasses); - setClassLayout(new Layout(this, NIL, NIL)); - } - - @Override - public LispObject typeOf() - { - return Symbol.STANDARD_CLASS; + super(layoutStandardClass, + symbol, directSuperclasses); } @Override @@ -114,6 +131,16 @@ public static final StandardClass STANDARD_OBJECT = addStandardClass(Symbol.STANDARD_OBJECT, list(BuiltInClass.CLASS_T)); + public static final StandardClass SLOT_DEFINITION = + new SlotDefinitionClass(); + static + { + addClass(Symbol.SLOT_DEFINITION, SLOT_DEFINITION); + + STANDARD_CLASS.setClassLayout(layoutStandardClass); + STANDARD_CLASS.setDirectSlotDefinitions(STANDARD_CLASS.getClassLayout().generateSlotDefinitions()); + } + // BuiltInClass.FUNCTION is also null here (see previous comment). public static final StandardClass GENERIC_FUNCTION = addStandardClass(Symbol.GENERIC_FUNCTION, list(BuiltInClass.FUNCTION, @@ -259,13 +286,6 @@ addClass(Symbol.STANDARD_GENERIC_FUNCTION, STANDARD_GENERIC_FUNCTION); } - public static final StandardClass SLOT_DEFINITION = - new SlotDefinitionClass(); - static - { - addClass(Symbol.SLOT_DEFINITION, SLOT_DEFINITION); - } - public static void initializeStandardClasses() { // We need to call setDirectSuperclass() here for classes that have a From vvoutilainen at common-lisp.net Sat Feb 13 15:28:46 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sat, 13 Feb 2010 10:28:46 -0500 Subject: [armedbear-cvs] r12456 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sat Feb 13 10:28:44 2010 New Revision: 12456 Log: Stack-friendly SpecialOperators. Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Sat Feb 13 10:28:44 2010 @@ -40,9 +40,13 @@ public final class SpecialOperators { // ### quote - private static final SpecialOperator QUOTE = - new SpecialOperator(Symbol.QUOTE, "thing") - { + private static final SpecialOperator QUOTE = new sf_quote(); + private static final class sf_quote extends SpecialOperator { + sf_quote() + { + super(Symbol.QUOTE, "thing"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -54,9 +58,13 @@ }; // ### if - private static final SpecialOperator IF = - new SpecialOperator(Symbol.IF, "test then &optional else") - { + private static final SpecialOperator IF = new sf_if(); + private static final class sf_if extends SpecialOperator { + sf_if() + { + super(Symbol.IF, "test then &optional else"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -84,9 +92,13 @@ }; // ### let - private static final SpecialOperator LET = - new SpecialOperator(Symbol.LET, "bindings &body body") - { + private static final SpecialOperator LET = new sf_let(); + private static final class sf_let extends SpecialOperator { + sf_let() + { + super(Symbol.LET, "bindings &body body"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -98,9 +110,13 @@ }; // ### let* - private static final SpecialOperator LET_STAR = - new SpecialOperator(Symbol.LET_STAR, "bindings &body body") - { + private static final SpecialOperator LET_STAR = new sf_let_star(); + private static final class sf_let_star extends SpecialOperator { + sf_let_star() + { + super(Symbol.LET_STAR, "bindings &body body"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -173,9 +189,13 @@ } // ### symbol-macrolet - private static final SpecialOperator SYMBOL_MACROLET = - new SpecialOperator(Symbol.SYMBOL_MACROLET, "macrobindings &body body") - { + private static final SpecialOperator SYMBOL_MACROLET = new sf_symbol_macrolet(); + private static final class sf_symbol_macrolet extends SpecialOperator { + sf_symbol_macrolet() + { + super(Symbol.SYMBOL_MACROLET, "macrobindings &body body"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -223,10 +243,14 @@ }; // ### load-time-value form &optional read-only-p => object - private static final SpecialOperator LOAD_TIME_VALUE = - new SpecialOperator(Symbol.LOAD_TIME_VALUE, - "form &optional read-only-p") - { + private static final SpecialOperator LOAD_TIME_VALUE = new sf_load_time_value(); + private static final class sf_load_time_value extends SpecialOperator { + sf_load_time_value() + { + super(Symbol.LOAD_TIME_VALUE, + "form &optional read-only-p"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -244,9 +268,13 @@ }; // ### locally - private static final SpecialOperator LOCALLY = - new SpecialOperator(Symbol.LOCALLY, "&body body") - { + private static final SpecialOperator LOCALLY = new sf_locally(); + private static final class sf_locally extends SpecialOperator { + sf_locally() + { + super(Symbol.LOCALLY, "&body body"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -259,9 +287,13 @@ }; // ### progn - private static final SpecialOperator PROGN = - new SpecialOperator(Symbol.PROGN, "&rest forms") - { + private static final SpecialOperator PROGN = new sf_progn(); + private static final class sf_progn extends SpecialOperator { + sf_progn() + { + super(Symbol.PROGN, "&rest forms"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -272,9 +304,13 @@ }; // ### flet - private static final SpecialOperator FLET = - new SpecialOperator(Symbol.FLET, "definitions &body body") - { + private static final SpecialOperator FLET = new sf_flet(); + private static final class sf_flet extends SpecialOperator { + sf_flet() + { + super(Symbol.FLET, "definitions &body body"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -284,9 +320,13 @@ }; // ### labels - private static final SpecialOperator LABELS = - new SpecialOperator(Symbol.LABELS, "definitions &body body") - { + private static final SpecialOperator LABELS = new sf_labels(); + private static final class sf_labels extends SpecialOperator { + sf_labels() + { + super(Symbol.LABELS, "definitions &body body"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -364,9 +404,13 @@ } // ### the value-type form => result* - private static final SpecialOperator THE = - new SpecialOperator(Symbol.THE, "type value") - { + private static final SpecialOperator THE = new sf_the(); + private static final class sf_the extends SpecialOperator { + sf_the() + { + super(Symbol.THE, "type value"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -399,9 +443,13 @@ }; // ### progv - private static final SpecialOperator PROGV = - new SpecialOperator(Symbol.PROGV, "symbols values &body body") - { + private static final SpecialOperator PROGV = new sf_progv(); + private static final class sf_progv extends SpecialOperator { + sf_progv() + { + super(Symbol.PROGV, "symbols values &body body"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -427,9 +475,13 @@ }; // ### declare - private static final SpecialOperator DECLARE = - new SpecialOperator(Symbol.DECLARE, "&rest declaration-specifiers") - { + private static final SpecialOperator DECLARE = new sf_declare(); + private static final class sf_declare extends SpecialOperator { + sf_declare() + { + super(Symbol.DECLARE, "&rest declaration-specifiers"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -439,9 +491,13 @@ }; // ### function - private static final SpecialOperator FUNCTION = - new SpecialOperator(Symbol.FUNCTION, "thing") - { + private static final SpecialOperator FUNCTION = new sf_function(); + private static final class sf_function extends SpecialOperator { + sf_function() + { + super(Symbol.FUNCTION, "thing"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -497,9 +553,13 @@ }; // ### setq - private static final SpecialOperator SETQ = - new SpecialOperator(Symbol.SETQ, "&rest vars-and-values") - { + private static final SpecialOperator SETQ = new sf_setq(); + private static final class sf_setq extends SpecialOperator { + sf_setq() + { + super(Symbol.SETQ, "&rest vars-and-values"); + } + @Override public LispObject execute(LispObject args, Environment env) From vvoutilainen at common-lisp.net Sat Feb 13 15:42:13 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sat, 13 Feb 2010 10:42:13 -0500 Subject: [armedbear-cvs] r12457 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sat Feb 13 10:42:13 2010 New Revision: 12457 Log: Reindentation. Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Sat Feb 13 10:42:13 2010 @@ -37,618 +37,545 @@ import java.util.ArrayList; import java.util.LinkedList; -public final class SpecialOperators -{ - // ### quote - private static final SpecialOperator QUOTE = new sf_quote(); - private static final class sf_quote extends SpecialOperator { - sf_quote() - { - super(Symbol.QUOTE, "thing"); - } - - @Override - public LispObject execute(LispObject args, Environment env) - - { - if (args.cdr() != NIL) - return error(new WrongNumberOfArgumentsException(this)); - return args.car(); - } - }; - - // ### if - private static final SpecialOperator IF = new sf_if(); - private static final class sf_if extends SpecialOperator { - sf_if() - { - super(Symbol.IF, "test then &optional else"); - } - - @Override - public LispObject execute(LispObject args, Environment env) +public final class SpecialOperators { + // ### quote + private static final SpecialOperator QUOTE = new sf_quote(); + private static final class sf_quote extends SpecialOperator { + sf_quote() { + super(Symbol.QUOTE, "thing"); + } + + @Override + public LispObject execute(LispObject args, Environment env) + + { + if (args.cdr() != NIL) + return error(new WrongNumberOfArgumentsException(this)); + return args.car(); + } + }; + + // ### if + private static final SpecialOperator IF = new sf_if(); + private static final class sf_if extends SpecialOperator { + sf_if() { + super(Symbol.IF, "test then &optional else"); + } + + @Override + public LispObject execute(LispObject args, Environment env) + + { + final LispThread thread = LispThread.currentThread(); + switch (args.length()) { + case 2: { + if (eval(((Cons)args).car, env, thread) != NIL) + return eval(args.cadr(), env, thread); + thread.clearValues(); + return NIL; + } + case 3: { + if (eval(((Cons)args).car, env, thread) != NIL) + return eval(args.cadr(), env, thread); + return eval((((Cons)args).cdr).cadr(), env, thread); + } + default: + return error(new WrongNumberOfArgumentsException(this)); + } + } + }; - { - final LispThread thread = LispThread.currentThread(); - switch (args.length()) - { - case 2: - { - if (eval(((Cons)args).car, env, thread) != NIL) - return eval(args.cadr(), env, thread); - thread.clearValues(); - return NIL; - } - case 3: - { - if (eval(((Cons)args).car, env, thread) != NIL) - return eval(args.cadr(), env, thread); - return eval((((Cons)args).cdr).cadr(), env, thread); - } - default: - return error(new WrongNumberOfArgumentsException(this)); - } - } - }; - - // ### let - private static final SpecialOperator LET = new sf_let(); - private static final class sf_let extends SpecialOperator { - sf_let() - { - super(Symbol.LET, "bindings &body body"); - } - - @Override - public LispObject execute(LispObject args, Environment env) - - { - if (args == NIL) - return error(new WrongNumberOfArgumentsException(this)); - return _let(args, env, false); - } - }; - - // ### let* - private static final SpecialOperator LET_STAR = new sf_let_star(); - private static final class sf_let_star extends SpecialOperator { - sf_let_star() - { - super(Symbol.LET_STAR, "bindings &body body"); - } - - @Override - public LispObject execute(LispObject args, Environment env) - - { - if (args == NIL) - return error(new WrongNumberOfArgumentsException(this)); - return _let(args, env, true); - } - }; - - private static final LispObject _let(LispObject args, Environment env, - boolean sequential) - - { - final LispThread thread = LispThread.currentThread(); - final SpecialBindingsMark mark = thread.markSpecialBindings(); - try - { - LispObject varList = checkList(args.car()); - LispObject bodyAndDecls = parseBody(args.cdr(), false); - LispObject specials = parseSpecials(bodyAndDecls.NTH(1)); - LispObject body = bodyAndDecls.car(); - - Environment ext = new Environment(env); - LinkedList nonSequentialVars = new LinkedList(); - while (varList != NIL) - { - final Symbol symbol; - LispObject value; - LispObject obj = varList.car(); - if (obj instanceof Cons) - { - if (obj.length() > 2) - return error(new LispError("The " + (sequential ? "LET*" : "LET") - + " binding specification " + - obj.writeToString() + " is invalid.")); - symbol = checkSymbol(((Cons)obj).car); - value = eval(obj.cadr(), sequential ? ext : env, thread); - } - else - { - symbol = checkSymbol(obj); - value = NIL; - } - if (sequential) { - ext = new Environment(ext); - bindArg(specials, symbol, value, ext, thread); - } - else - nonSequentialVars.add(new Cons(symbol, value)); - varList = ((Cons)varList).cdr; - } - if (!sequential) - for (Cons x : nonSequentialVars) - bindArg(specials, (Symbol)x.car(), x.cdr(), ext, thread); - - // Make sure free special declarations are visible in the body. - // "The scope of free declarations specifically does not include - // initialization forms for bindings established by the form - // containing the declarations." (3.3.4) - for (; specials != NIL; specials = specials.cdr()) - ext.declareSpecial((Symbol)specials.car()); - - return progn(body, ext, thread); - } - finally - { - thread.resetSpecialBindings(mark); - } - } - - // ### symbol-macrolet - private static final SpecialOperator SYMBOL_MACROLET = new sf_symbol_macrolet(); - private static final class sf_symbol_macrolet extends SpecialOperator { - sf_symbol_macrolet() - { - super(Symbol.SYMBOL_MACROLET, "macrobindings &body body"); - } - - @Override - public LispObject execute(LispObject args, Environment env) + // ### let + private static final SpecialOperator LET = new sf_let(); + private static final class sf_let extends SpecialOperator { + sf_let() { + super(Symbol.LET, "bindings &body body"); + } + + @Override + public LispObject execute(LispObject args, Environment env) - { - LispObject varList = checkList(args.car()); + { + if (args == NIL) + return error(new WrongNumberOfArgumentsException(this)); + return _let(args, env, false); + } + }; + + // ### let* + private static final SpecialOperator LET_STAR = new sf_let_star(); + private static final class sf_let_star extends SpecialOperator { + sf_let_star() { + super(Symbol.LET_STAR, "bindings &body body"); + } + + @Override + public LispObject execute(LispObject args, Environment env) + + { + if (args == NIL) + return error(new WrongNumberOfArgumentsException(this)); + return _let(args, env, true); + } + }; + + private static final LispObject _let(LispObject args, Environment env, + boolean sequential) + + { final LispThread thread = LispThread.currentThread(); final SpecialBindingsMark mark = thread.markSpecialBindings(); - Environment ext = new Environment(env); - try - { - // Declare our free specials, this will correctly raise - LispObject body = ext.processDeclarations(args.cdr()); - - for (int i = varList.length(); i-- > 0;) - { - LispObject obj = varList.car(); - varList = varList.cdr(); - if (obj instanceof Cons && obj.length() == 2) - { - Symbol symbol = checkSymbol(obj.car()); - if (symbol.isSpecialVariable() - || ext.isDeclaredSpecial(symbol)) - { - return error(new ProgramError( - "Attempt to bind the special variable " + - symbol.writeToString() + - " with SYMBOL-MACROLET.")); - } - bindArg(null, symbol, new SymbolMacro(obj.cadr()), ext, thread); - } - else - { - return error(new ProgramError( - "Malformed symbol-expansion pair in SYMBOL-MACROLET: " + - obj.writeToString())); - } + try { + LispObject varList = checkList(args.car()); + LispObject bodyAndDecls = parseBody(args.cdr(), false); + LispObject specials = parseSpecials(bodyAndDecls.NTH(1)); + LispObject body = bodyAndDecls.car(); + + Environment ext = new Environment(env); + LinkedList nonSequentialVars = new LinkedList(); + while (varList != NIL) { + final Symbol symbol; + LispObject value; + LispObject obj = varList.car(); + if (obj instanceof Cons) { + if (obj.length() > 2) + return error(new LispError("The " + (sequential ? "LET*" : "LET") + + " binding specification " + + obj.writeToString() + " is invalid.")); + symbol = checkSymbol(((Cons)obj).car); + value = eval(obj.cadr(), sequential ? ext : env, thread); + } else { + symbol = checkSymbol(obj); + value = NIL; } - return progn(body, ext, thread); - } - finally - { - thread.resetSpecialBindings(mark); - } - } - }; - - // ### load-time-value form &optional read-only-p => object - private static final SpecialOperator LOAD_TIME_VALUE = new sf_load_time_value(); - private static final class sf_load_time_value extends SpecialOperator { - sf_load_time_value() - { - super(Symbol.LOAD_TIME_VALUE, - "form &optional read-only-p"); - } - - @Override - public LispObject execute(LispObject args, Environment env) - - { - switch (args.length()) - { - case 1: - case 2: - return eval(args.car(), new Environment(), - LispThread.currentThread()); - default: - return error(new WrongNumberOfArgumentsException(this)); - } - } - }; - - // ### locally - private static final SpecialOperator LOCALLY = new sf_locally(); - private static final class sf_locally extends SpecialOperator { - sf_locally() - { - super(Symbol.LOCALLY, "&body body"); - } - - @Override - public LispObject execute(LispObject args, Environment env) + if (sequential) { + ext = new Environment(ext); + bindArg(specials, symbol, value, ext, thread); + } else + nonSequentialVars.add(new Cons(symbol, value)); + varList = ((Cons)varList).cdr; + } + if (!sequential) +for (Cons x : nonSequentialVars) + bindArg(specials, (Symbol)x.car(), x.cdr(), ext, thread); + + // Make sure free special declarations are visible in the body. + // "The scope of free declarations specifically does not include + // initialization forms for bindings established by the form + // containing the declarations." (3.3.4) + for (; specials != NIL; specials = specials.cdr()) + ext.declareSpecial((Symbol)specials.car()); + + return progn(body, ext, thread); + } + finally { + thread.resetSpecialBindings(mark); + } + } - { - final LispThread thread = LispThread.currentThread(); - final Environment ext = new Environment(env); - args = ext.processDeclarations(args); - return progn(args, ext, thread); - } - }; - - // ### progn - private static final SpecialOperator PROGN = new sf_progn(); - private static final class sf_progn extends SpecialOperator { - sf_progn() - { - super(Symbol.PROGN, "&rest forms"); - } - - @Override - public LispObject execute(LispObject args, Environment env) - - { - LispThread thread = LispThread.currentThread(); - return progn(args, env, thread); - } - }; - - // ### flet - private static final SpecialOperator FLET = new sf_flet(); - private static final class sf_flet extends SpecialOperator { - sf_flet() - { - super(Symbol.FLET, "definitions &body body"); - } - - @Override - public LispObject execute(LispObject args, Environment env) - - { - return _flet(args, env, false); - } - }; - - // ### labels - private static final SpecialOperator LABELS = new sf_labels(); - private static final class sf_labels extends SpecialOperator { - sf_labels() - { - super(Symbol.LABELS, "definitions &body body"); - } - - @Override - public LispObject execute(LispObject args, Environment env) - - { - return _flet(args, env, true); - } - }; - - private static final LispObject _flet(LispObject args, Environment env, - boolean recursive) - - { - // First argument is a list of local function definitions. - LispObject defs = checkList(args.car()); - final LispThread thread = LispThread.currentThread(); - final SpecialBindingsMark mark = thread.markSpecialBindings(); - final Environment funEnv = new Environment(env); - while (defs != NIL) - { - final LispObject def = checkList(defs.car()); - final LispObject name = def.car(); - final Symbol symbol; - if (name instanceof Symbol) - { - symbol = checkSymbol(name); - if (symbol.getSymbolFunction() instanceof SpecialOperator) - { - String message = - symbol.getName() + " is a special operator and may not be redefined"; - return error(new ProgramError(message)); - } - } - else if (isValidSetfFunctionName(name)) - symbol = checkSymbol(name.cadr()); - else - return type_error(name, FUNCTION_NAME); - LispObject rest = def.cdr(); - LispObject parameters = rest.car(); - LispObject body = rest.cdr(); - LispObject decls = NIL; - while (body.car() instanceof Cons && body.car().car() == Symbol.DECLARE) - { - decls = new Cons(body.car(), decls); - body = body.cdr(); - } - body = new Cons(symbol, body); - body = new Cons(Symbol.BLOCK, body); - body = new Cons(body, NIL); - while (decls != NIL) - { - body = new Cons(decls.car(), body); - decls = decls.cdr(); - } - LispObject lambda_expression = - new Cons(Symbol.LAMBDA, new Cons(parameters, body)); - LispObject lambda_name = - list(recursive ? Symbol.LABELS : Symbol.FLET, name); - Closure closure = - new Closure(lambda_name, lambda_expression, - recursive ? funEnv : env); - funEnv.addFunctionBinding(name, closure); - defs = defs.cdr(); - } - try - { - final Environment ext = new Environment(funEnv); - LispObject body = args.cdr(); - body = ext.processDeclarations(body); - return progn(body, ext, thread); - } - finally - { - thread.resetSpecialBindings(mark); - } - } - - // ### the value-type form => result* - private static final SpecialOperator THE = new sf_the(); - private static final class sf_the extends SpecialOperator { - sf_the() - { - super(Symbol.THE, "type value"); - } - - @Override - public LispObject execute(LispObject args, Environment env) - - { - if (args.length() != 2) - return error(new WrongNumberOfArgumentsException(this)); - LispObject rv = eval(args.cadr(), env, LispThread.currentThread()); - - // check only the most simple types: single symbols - // (class type specifiers/primitive types) - // DEFTYPE-d types need expansion; - // doing so would slow down our execution too much - - // An implementation is allowed not to check the type, - // the fact that we do so here is mainly driven by the - // requirement to verify argument types in structure-slot - // accessors (defstruct.lisp) - - // The policy below is in line with the level of verification - // in the compiler at *safety* levels below 3 - LispObject type = args.car(); - if ((type instanceof Symbol - && get(type, Symbol.DEFTYPE_DEFINITION) == NIL) - || type instanceof BuiltInClass) - if (rv.typep(type) == NIL) - type_error(rv, type); - - return rv; - } - }; - - // ### progv - private static final SpecialOperator PROGV = new sf_progv(); - private static final class sf_progv extends SpecialOperator { - sf_progv() - { - super(Symbol.PROGV, "symbols values &body body"); - } - - @Override - public LispObject execute(LispObject args, Environment env) - - { - if (args.length() < 2) - return error(new WrongNumberOfArgumentsException(this)); + // ### symbol-macrolet + private static final SpecialOperator SYMBOL_MACROLET = new sf_symbol_macrolet(); + private static final class sf_symbol_macrolet extends SpecialOperator { + sf_symbol_macrolet() { + super(Symbol.SYMBOL_MACROLET, "macrobindings &body body"); + } + + @Override + public LispObject execute(LispObject args, Environment env) + + { + LispObject varList = checkList(args.car()); + final LispThread thread = LispThread.currentThread(); + final SpecialBindingsMark mark = thread.markSpecialBindings(); + Environment ext = new Environment(env); + try { + // Declare our free specials, this will correctly raise + LispObject body = ext.processDeclarations(args.cdr()); + + for (int i = varList.length(); i-- > 0;) { + LispObject obj = varList.car(); + varList = varList.cdr(); + if (obj instanceof Cons && obj.length() == 2) { + Symbol symbol = checkSymbol(obj.car()); + if (symbol.isSpecialVariable() + || ext.isDeclaredSpecial(symbol)) { + return error(new ProgramError( + "Attempt to bind the special variable " + + symbol.writeToString() + + " with SYMBOL-MACROLET.")); + } + bindArg(null, symbol, new SymbolMacro(obj.cadr()), ext, thread); + } else { + return error(new ProgramError( + "Malformed symbol-expansion pair in SYMBOL-MACROLET: " + + obj.writeToString())); + } + } + return progn(body, ext, thread); + } + finally { + thread.resetSpecialBindings(mark); + } + } + }; + + // ### load-time-value form &optional read-only-p => object + private static final SpecialOperator LOAD_TIME_VALUE = new sf_load_time_value(); + private static final class sf_load_time_value extends SpecialOperator { + sf_load_time_value() { + super(Symbol.LOAD_TIME_VALUE, + "form &optional read-only-p"); + } + + @Override + public LispObject execute(LispObject args, Environment env) + + { + switch (args.length()) { + case 1: + case 2: + return eval(args.car(), new Environment(), + LispThread.currentThread()); + default: + return error(new WrongNumberOfArgumentsException(this)); + } + } + }; + + // ### locally + private static final SpecialOperator LOCALLY = new sf_locally(); + private static final class sf_locally extends SpecialOperator { + sf_locally() { + super(Symbol.LOCALLY, "&body body"); + } + + @Override + public LispObject execute(LispObject args, Environment env) + + { + final LispThread thread = LispThread.currentThread(); + final Environment ext = new Environment(env); + args = ext.processDeclarations(args); + return progn(args, ext, thread); + } + }; + + // ### progn + private static final SpecialOperator PROGN = new sf_progn(); + private static final class sf_progn extends SpecialOperator { + sf_progn() { + super(Symbol.PROGN, "&rest forms"); + } + + @Override + public LispObject execute(LispObject args, Environment env) + + { + LispThread thread = LispThread.currentThread(); + return progn(args, env, thread); + } + }; + + // ### flet + private static final SpecialOperator FLET = new sf_flet(); + private static final class sf_flet extends SpecialOperator { + sf_flet() { + super(Symbol.FLET, "definitions &body body"); + } + + @Override + public LispObject execute(LispObject args, Environment env) + + { + return _flet(args, env, false); + } + }; + + // ### labels + private static final SpecialOperator LABELS = new sf_labels(); + private static final class sf_labels extends SpecialOperator { + sf_labels() { + super(Symbol.LABELS, "definitions &body body"); + } + + @Override + public LispObject execute(LispObject args, Environment env) + + { + return _flet(args, env, true); + } + }; + + private static final LispObject _flet(LispObject args, Environment env, + boolean recursive) + + { + // First argument is a list of local function definitions. + LispObject defs = checkList(args.car()); final LispThread thread = LispThread.currentThread(); - final LispObject symbols = checkList(eval(args.car(), env, thread)); - LispObject values = checkList(eval(args.cadr(), env, thread)); final SpecialBindingsMark mark = thread.markSpecialBindings(); - try - { - // Set up the new bindings. - progvBindVars(symbols, values, thread); - // Implicit PROGN. - return progn(args.cdr().cdr(), env, thread); - } - finally - { + final Environment funEnv = new Environment(env); + while (defs != NIL) { + final LispObject def = checkList(defs.car()); + final LispObject name = def.car(); + final Symbol symbol; + if (name instanceof Symbol) { + symbol = checkSymbol(name); + if (symbol.getSymbolFunction() instanceof SpecialOperator) { + String message = + symbol.getName() + " is a special operator and may not be redefined"; + return error(new ProgramError(message)); + } + } else if (isValidSetfFunctionName(name)) + symbol = checkSymbol(name.cadr()); + else + return type_error(name, FUNCTION_NAME); + LispObject rest = def.cdr(); + LispObject parameters = rest.car(); + LispObject body = rest.cdr(); + LispObject decls = NIL; + while (body.car() instanceof Cons && body.car().car() == Symbol.DECLARE) { + decls = new Cons(body.car(), decls); + body = body.cdr(); + } + body = new Cons(symbol, body); + body = new Cons(Symbol.BLOCK, body); + body = new Cons(body, NIL); + while (decls != NIL) { + body = new Cons(decls.car(), body); + decls = decls.cdr(); + } + LispObject lambda_expression = + new Cons(Symbol.LAMBDA, new Cons(parameters, body)); + LispObject lambda_name = + list(recursive ? Symbol.LABELS : Symbol.FLET, name); + Closure closure = + new Closure(lambda_name, lambda_expression, + recursive ? funEnv : env); + funEnv.addFunctionBinding(name, closure); + defs = defs.cdr(); + } + try { + final Environment ext = new Environment(funEnv); + LispObject body = args.cdr(); + body = ext.processDeclarations(body); + return progn(body, ext, thread); + } + finally { thread.resetSpecialBindings(mark); - } - } + } + } + + // ### the value-type form => result* + private static final SpecialOperator THE = new sf_the(); + private static final class sf_the extends SpecialOperator { + sf_the() { + super(Symbol.THE, "type value"); + } + + @Override + public LispObject execute(LispObject args, Environment env) + + { + if (args.length() != 2) + return error(new WrongNumberOfArgumentsException(this)); + LispObject rv = eval(args.cadr(), env, LispThread.currentThread()); + + // check only the most simple types: single symbols + // (class type specifiers/primitive types) + // DEFTYPE-d types need expansion; + // doing so would slow down our execution too much + + // An implementation is allowed not to check the type, + // the fact that we do so here is mainly driven by the + // requirement to verify argument types in structure-slot + // accessors (defstruct.lisp) + + // The policy below is in line with the level of verification + // in the compiler at *safety* levels below 3 + LispObject type = args.car(); + if ((type instanceof Symbol + && get(type, Symbol.DEFTYPE_DEFINITION) == NIL) + || type instanceof BuiltInClass) + if (rv.typep(type) == NIL) + type_error(rv, type); + + return rv; + } + }; + + // ### progv + private static final SpecialOperator PROGV = new sf_progv(); + private static final class sf_progv extends SpecialOperator { + sf_progv() { + super(Symbol.PROGV, "symbols values &body body"); + } + + @Override + public LispObject execute(LispObject args, Environment env) + + { + if (args.length() < 2) + return error(new WrongNumberOfArgumentsException(this)); + final LispThread thread = LispThread.currentThread(); + final LispObject symbols = checkList(eval(args.car(), env, thread)); + LispObject values = checkList(eval(args.cadr(), env, thread)); + final SpecialBindingsMark mark = thread.markSpecialBindings(); + try { + // Set up the new bindings. + progvBindVars(symbols, values, thread); + // Implicit PROGN. + return progn(args.cdr().cdr(), env, thread); + } + finally { + thread.resetSpecialBindings(mark); + } + } }; - // ### declare - private static final SpecialOperator DECLARE = new sf_declare(); - private static final class sf_declare extends SpecialOperator { - sf_declare() - { - super(Symbol.DECLARE, "&rest declaration-specifiers"); - } - - @Override - public LispObject execute(LispObject args, Environment env) - - { - return NIL; - } - }; - - // ### function - private static final SpecialOperator FUNCTION = new sf_function(); - private static final class sf_function extends SpecialOperator { - sf_function() - { - super(Symbol.FUNCTION, "thing"); - } - - @Override - public LispObject execute(LispObject args, Environment env) - - { - final LispObject arg = args.car(); - if (arg instanceof Symbol) - { - LispObject operator = env.lookupFunction(arg); - if (operator instanceof Autoload) - { - Autoload autoload = (Autoload) operator; - autoload.load(); - operator = autoload.getSymbol().getSymbolFunction(); - } - if (operator instanceof Function) - return operator; - if (operator instanceof StandardGenericFunction) - return operator; - return error(new UndefinedFunction(arg)); - } - if (arg instanceof Cons) - { - LispObject car = ((Cons)arg).car; - if (car == Symbol.SETF) - { - LispObject f = env.lookupFunction(arg); - if (f != null) - return f; - Symbol symbol = checkSymbol(arg.cadr()); - f = get(symbol, Symbol.SETF_FUNCTION, null); - if (f != null) - return f; - f = get(symbol, Symbol.SETF_INVERSE, null); - if (f != null) - return f; - } - if (car == Symbol.LAMBDA) - return new Closure(arg, env); - if (car == Symbol.NAMED_LAMBDA) - { - LispObject name = arg.cadr(); - if (name instanceof Symbol || isValidSetfFunctionName(name)) - { - return new Closure(name, - new Cons(Symbol.LAMBDA, arg.cddr()), - env); - } - return type_error(name, FUNCTION_NAME); - } - } - return error(new UndefinedFunction(list(Keyword.NAME, arg))); - } - }; - - // ### setq - private static final SpecialOperator SETQ = new sf_setq(); - private static final class sf_setq extends SpecialOperator { - sf_setq() - { - super(Symbol.SETQ, "&rest vars-and-values"); - } - - @Override - public LispObject execute(LispObject args, Environment env) + // ### declare + private static final SpecialOperator DECLARE = new sf_declare(); + private static final class sf_declare extends SpecialOperator { + sf_declare() { + super(Symbol.DECLARE, "&rest declaration-specifiers"); + } + + @Override + public LispObject execute(LispObject args, Environment env) + + { + return NIL; + } + }; + + // ### function + private static final SpecialOperator FUNCTION = new sf_function(); + private static final class sf_function extends SpecialOperator { + sf_function() { + super(Symbol.FUNCTION, "thing"); + } + + @Override + public LispObject execute(LispObject args, Environment env) + + { + final LispObject arg = args.car(); + if (arg instanceof Symbol) { + LispObject operator = env.lookupFunction(arg); + if (operator instanceof Autoload) { + Autoload autoload = (Autoload) operator; + autoload.load(); + operator = autoload.getSymbol().getSymbolFunction(); + } + if (operator instanceof Function) + return operator; + if (operator instanceof StandardGenericFunction) + return operator; + return error(new UndefinedFunction(arg)); + } + if (arg instanceof Cons) { + LispObject car = ((Cons)arg).car; + if (car == Symbol.SETF) { + LispObject f = env.lookupFunction(arg); + if (f != null) + return f; + Symbol symbol = checkSymbol(arg.cadr()); + f = get(symbol, Symbol.SETF_FUNCTION, null); + if (f != null) + return f; + f = get(symbol, Symbol.SETF_INVERSE, null); + if (f != null) + return f; + } + if (car == Symbol.LAMBDA) + return new Closure(arg, env); + if (car == Symbol.NAMED_LAMBDA) { + LispObject name = arg.cadr(); + if (name instanceof Symbol || isValidSetfFunctionName(name)) { + return new Closure(name, + new Cons(Symbol.LAMBDA, arg.cddr()), + env); + } + return type_error(name, FUNCTION_NAME); + } + } + return error(new UndefinedFunction(list(Keyword.NAME, arg))); + } + }; - { - LispObject value = Nil.NIL; - final LispThread thread = LispThread.currentThread(); - while (args != NIL) - { - Symbol symbol = checkSymbol(args.car()); - if (symbol.isConstant()) - { - return error(new ProgramError(symbol.writeToString() + - " is a constant and thus cannot be set.")); - } - args = args.cdr(); - if (symbol.isSpecialVariable() || env.isDeclaredSpecial(symbol)) - { - SpecialBinding binding = thread.getSpecialBinding(symbol); - if (binding != null) - { - if (binding.value instanceof SymbolMacro) - { - LispObject expansion = - ((SymbolMacro)binding.value).getExpansion(); - LispObject form = list(Symbol.SETF, expansion, args.car()); - value = eval(form, env, thread); - } - else - { - value = eval(args.car(), env, thread); - binding.value = value; - } - } - else - { - if (symbol.getSymbolValue() instanceof SymbolMacro) - { - LispObject expansion = - ((SymbolMacro)symbol.getSymbolValue()).getExpansion(); - LispObject form = list(Symbol.SETF, expansion, args.car()); - value = eval(form, env, thread); - } - else - { - value = eval(args.car(), env, thread); - symbol.setSymbolValue(value); - } - } - } - else - { - // Not special. - Binding binding = env.getBinding(symbol); - if (binding != null) - { - if (binding.value instanceof SymbolMacro) - { - LispObject expansion = - ((SymbolMacro)binding.value).getExpansion(); - LispObject form = list(Symbol.SETF, expansion, args.car()); - value = eval(form, env, thread); - } - else - { - value = eval(args.car(), env, thread); - binding.value = value; - } - } - else - { - if (symbol.getSymbolValue() instanceof SymbolMacro) - { - LispObject expansion = - ((SymbolMacro)symbol.getSymbolValue()).getExpansion(); - LispObject form = list(Symbol.SETF, expansion, args.car()); - value = eval(form, env, thread); - } - else - { - value = eval(args.car(), env, thread); - symbol.setSymbolValue(value); - } - } - } - args = args.cdr(); - } - // Return primary value only! - thread._values = null; - return value; - } + // ### setq + private static final SpecialOperator SETQ = new sf_setq(); + private static final class sf_setq extends SpecialOperator { + sf_setq() { + super(Symbol.SETQ, "&rest vars-and-values"); + } + + @Override + public LispObject execute(LispObject args, Environment env) + + { + LispObject value = Nil.NIL; + final LispThread thread = LispThread.currentThread(); + while (args != NIL) { + Symbol symbol = checkSymbol(args.car()); + if (symbol.isConstant()) { + return error(new ProgramError(symbol.writeToString() + + " is a constant and thus cannot be set.")); + } + args = args.cdr(); + if (symbol.isSpecialVariable() || env.isDeclaredSpecial(symbol)) { + SpecialBinding binding = thread.getSpecialBinding(symbol); + if (binding != null) { + if (binding.value instanceof SymbolMacro) { + LispObject expansion = + ((SymbolMacro)binding.value).getExpansion(); + LispObject form = list(Symbol.SETF, expansion, args.car()); + value = eval(form, env, thread); + } else { + value = eval(args.car(), env, thread); + binding.value = value; + } + } else { + if (symbol.getSymbolValue() instanceof SymbolMacro) { + LispObject expansion = + ((SymbolMacro)symbol.getSymbolValue()).getExpansion(); + LispObject form = list(Symbol.SETF, expansion, args.car()); + value = eval(form, env, thread); + } else { + value = eval(args.car(), env, thread); + symbol.setSymbolValue(value); + } + } + } else { + // Not special. + Binding binding = env.getBinding(symbol); + if (binding != null) { + if (binding.value instanceof SymbolMacro) { + LispObject expansion = + ((SymbolMacro)binding.value).getExpansion(); + LispObject form = list(Symbol.SETF, expansion, args.car()); + value = eval(form, env, thread); + } else { + value = eval(args.car(), env, thread); + binding.value = value; + } + } else { + if (symbol.getSymbolValue() instanceof SymbolMacro) { + LispObject expansion = + ((SymbolMacro)symbol.getSymbolValue()).getExpansion(); + LispObject form = list(Symbol.SETF, expansion, args.car()); + value = eval(form, env, thread); + } else { + value = eval(args.car(), env, thread); + symbol.setSymbolValue(value); + } + } + } + args = args.cdr(); + } + // Return primary value only! + thread._values = null; + return value; + } }; } From vvoutilainen at common-lisp.net Sat Feb 13 16:51:04 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sat, 13 Feb 2010 11:51:04 -0500 Subject: [armedbear-cvs] r12458 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sat Feb 13 11:51:02 2010 New Revision: 12458 Log: More stack-friendly SpecialOperators. Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.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 Sat Feb 13 11:51:02 2010 @@ -811,8 +811,12 @@ }; // ### when - private static final SpecialOperator WHEN = - new SpecialOperator(Symbol.WHEN) { + private static final SpecialOperator WHEN = new sf_when(); + private static final class sf_when extends SpecialOperator { + sf_when() { + super(Symbol.WHEN); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -830,8 +834,12 @@ }; // ### unless - private static final SpecialOperator UNLESS = - new SpecialOperator(Symbol.UNLESS) { + private static final SpecialOperator UNLESS = new sf_unless(); + private static final class sf_unless extends SpecialOperator { + sf_unless() { + super(Symbol.UNLESS); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -1852,8 +1860,12 @@ }; // ### defmacro - private static final SpecialOperator DEFMACRO = - new SpecialOperator(Symbol.DEFMACRO) { + private static final SpecialOperator DEFMACRO = new sf_defmacro(); + private static final class sf_defmacro extends SpecialOperator { + sf_defmacro() { + super(Symbol.DEFMACRO); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -2013,8 +2025,12 @@ }; // ### cond - private static final SpecialOperator COND = - new SpecialOperator(Symbol.COND, "&rest clauses") { + private static final SpecialOperator COND = new sf_cond(); + private static final class sf_cond extends SpecialOperator { + sf_cond() { + super(Symbol.COND, "&rest clauses"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -2040,8 +2056,12 @@ }; // ### case - private static final SpecialOperator CASE = - new SpecialOperator(Symbol.CASE, "keyform &body cases") { + private static final SpecialOperator CASE = new sf_case(); + private static final class sf_case extends SpecialOperator { + sf_case() { + super(Symbol.CASE, "keyform &body cases"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -2079,8 +2099,12 @@ }; // ### ecase - private static final SpecialOperator ECASE = - new SpecialOperator(Symbol.ECASE, "keyform &body cases") { + private static final SpecialOperator ECASE = new sf_ecase(); + private static final class sf_ecase extends SpecialOperator { + sf_ecase() { + super(Symbol.ECASE, "keyform &body cases"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -3561,8 +3585,12 @@ }; // ### macrolet - private static final SpecialOperator MACROLET = - new SpecialOperator(Symbol.MACROLET, "definitions &rest body") { + private static final SpecialOperator MACROLET = new sf_macrolet(); + private static final class sf_macrolet extends SpecialOperator { + sf_macrolet() { + super(Symbol.MACROLET, "definitions &rest body"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -3624,8 +3652,12 @@ }; // ### tagbody - private static final SpecialOperator TAGBODY = - new SpecialOperator(Symbol.TAGBODY, "&rest statements") { + private static final SpecialOperator TAGBODY = new sf_tagbody(); + private static final class sf_tagbody extends SpecialOperator { + sf_tagbody() { + super(Symbol.TAGBODY, "&rest statements"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -3641,8 +3673,12 @@ }; // ### go - private static final SpecialOperator GO = - new SpecialOperator(Symbol.GO, "tag") { + private static final SpecialOperator GO = new sf_go(); + private static final class sf_go extends SpecialOperator { + sf_go() { + super(Symbol.GO, "tag"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -3660,8 +3696,12 @@ }; // ### block - private static final SpecialOperator BLOCK = - new SpecialOperator(Symbol.BLOCK, "name &rest forms") { + private static final SpecialOperator BLOCK = new sf_block(); + private static final class sf_block extends SpecialOperator { + sf_block() { + super(Symbol.BLOCK, "name &rest forms"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -3691,8 +3731,12 @@ }; // ### return-from - private static final SpecialOperator RETURN_FROM = - new SpecialOperator(Symbol.RETURN_FROM, "name &optional value") { + private static final SpecialOperator RETURN_FROM = new sf_return_from(); + private static final class sf_return_from extends SpecialOperator { + sf_return_from() { + super(Symbol.RETURN_FROM, "name &optional value"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -3711,8 +3755,12 @@ }; // ### catch - private static final SpecialOperator CATCH = - new SpecialOperator(Symbol.CATCH, "tag &body body") { + private static final SpecialOperator CATCH = new sf_catch(); + private static final class sf_catch extends SpecialOperator { + sf_catch() { + super(Symbol.CATCH, "tag &body body"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -3741,8 +3789,12 @@ }; // ### throw - private static final SpecialOperator THROW = - new SpecialOperator(Symbol.THROW, "tag result") { + private static final SpecialOperator THROW = new sf_throw(); + private static final class sf_throw extends SpecialOperator { + sf_throw() { + super(Symbol.THROW, "tag result"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -3758,8 +3810,12 @@ }; // ### unwind-protect - private static final SpecialOperator UNWIND_PROTECT = - new SpecialOperator(Symbol.UNWIND_PROTECT, "protected &body cleanup") { + private static final SpecialOperator UNWIND_PROTECT = new sf_unwind_protect(); + private static final class sf_unwind_protect extends SpecialOperator { + sf_unwind_protect() { + super(Symbol.UNWIND_PROTECT, "protected &body cleanup"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -3788,8 +3844,12 @@ }; // ### eval-when - private static final SpecialOperator EVAL_WHEN = - new SpecialOperator(Symbol.EVAL_WHEN, "situations &rest forms") { + private static final SpecialOperator EVAL_WHEN = new sf_eval_when(); + private static final class sf_eval_when extends SpecialOperator { + sf_eval_when() { + super(Symbol.EVAL_WHEN, "situations &rest forms"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -3797,7 +3857,7 @@ LispObject situations = args.car(); if (situations != NIL) { if (memq(Keyword.EXECUTE, situations) || - memq(Symbol.EVAL, situations)) { + memq(Symbol.EVAL, situations)) { return progn(args.cdr(), env, LispThread.currentThread()); } } @@ -3808,9 +3868,13 @@ // ### multiple-value-bind // multiple-value-bind (var*) values-form declaration* form* // Should be a macro. - private static final SpecialOperator MULTIPLE_VALUE_BIND = - new SpecialOperator(Symbol.MULTIPLE_VALUE_BIND, - "vars value-form &body body") { + private static final SpecialOperator MULTIPLE_VALUE_BIND = new sf_multiple_value_bind(); + private static final class sf_multiple_value_bind extends SpecialOperator { + sf_multiple_value_bind() { + super(Symbol.MULTIPLE_VALUE_BIND, + "vars value-form &body body"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -3875,9 +3939,13 @@ }; // ### multiple-value-prog1 - private static final SpecialOperator MULTIPLE_VALUE_PROG1 = - new SpecialOperator(Symbol.MULTIPLE_VALUE_PROG1, - "values-form &rest forms") { + private static final SpecialOperator MULTIPLE_VALUE_PROG1 = new sf_multiple_value_prog1(); + private static final class sf_multiple_value_prog1 extends SpecialOperator { + sf_multiple_value_prog1() { + super(Symbol.MULTIPLE_VALUE_PROG1, + "values-form &rest forms"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -3898,8 +3966,12 @@ }; // ### multiple-value-call - private static final SpecialOperator MULTIPLE_VALUE_CALL = - new SpecialOperator(Symbol.MULTIPLE_VALUE_CALL, "fun &rest args") { + private static final SpecialOperator MULTIPLE_VALUE_CALL = new sf_multiple_value_call(); + private static final class sf_multiple_value_call extends SpecialOperator { + sf_multiple_value_call() { + super(Symbol.MULTIPLE_VALUE_CALL, "fun &rest args"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -3941,8 +4013,12 @@ // ### and // Should be a macro. - private static final SpecialOperator AND = - new SpecialOperator(Symbol.AND, "&rest forms") { + private static final SpecialOperator AND = new sf_and(); + private static final class sf_and extends SpecialOperator { + sf_and() { + super(Symbol.AND, "&rest forms"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -3966,8 +4042,12 @@ // ### or // Should be a macro. - private static final SpecialOperator OR = - new SpecialOperator(Symbol.OR, "&rest forms") { + private static final SpecialOperator OR = new sf_or(); + private static final class sf_or extends SpecialOperator { + sf_or() { + super(Symbol.OR, "&rest forms"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -3992,8 +4072,12 @@ // ### multiple-value-list form => list // Evaluates form and creates a list of the multiple values it returns. // Should be a macro. - private static final SpecialOperator MULTIPLE_VALUE_LIST = - new SpecialOperator(Symbol.MULTIPLE_VALUE_LIST, "value-form") { + private static final SpecialOperator MULTIPLE_VALUE_LIST = new sf_multiple_value_list(); + private static final class sf_multiple_value_list extends SpecialOperator { + sf_multiple_value_list() { + super(Symbol.MULTIPLE_VALUE_LIST, "value-form"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -4017,8 +4101,12 @@ // Evaluates n and then form and returns the nth value returned by form, or // NIL if n >= number of values returned. // Should be a macro. - private static final SpecialOperator NTH_VALUE = - new SpecialOperator(Symbol.NTH_VALUE, "n form") { + private static final SpecialOperator NTH_VALUE = new sf_nth_value(); + private static final class sf_nth_value extends SpecialOperator { + sf_nth_value() { + super(Symbol.NTH_VALUE, "n form"); + } + @Override public LispObject execute(LispObject args, Environment env) From vvoutilainen at common-lisp.net Sat Feb 13 17:55:03 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sat, 13 Feb 2010 12:55:03 -0500 Subject: [armedbear-cvs] r12459 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sat Feb 13 12:54:59 2010 New Revision: 12459 Log: Stack friendliness. Modified: trunk/abcl/src/org/armedbear/lisp/Do.java Modified: trunk/abcl/src/org/armedbear/lisp/Do.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Do.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Do.java Sat Feb 13 12:54:59 2010 @@ -38,9 +38,13 @@ public final class Do { // ### do - private static final SpecialOperator DO = - new SpecialOperator(Symbol.DO, "varlist endlist &body body") - { + private static final SpecialOperator DO = new sf_do(); + private static final class sf_do extends SpecialOperator { + sf_do() + { + super(Symbol.DO, "varlist endlist &body body"); + } + @Override public LispObject execute(LispObject args, Environment env) @@ -50,9 +54,13 @@ }; // ### do* - private static final SpecialOperator DO_STAR = - new SpecialOperator(Symbol.DO_STAR, "varlist endlist &body body") - { + private static final SpecialOperator DO_STAR = new sf_do_star(); + private static final class sf_do_star extends SpecialOperator { + sf_do_star() + { + super(Symbol.DO_STAR, "varlist endlist &body body"); + } + @Override public LispObject execute(LispObject args, Environment env) From vvoutilainen at common-lisp.net Sat Feb 13 19:20:51 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sat, 13 Feb 2010 14:20:51 -0500 Subject: [armedbear-cvs] r12460 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sat Feb 13 14:20:48 2010 New Revision: 12460 Log: Reindentation. Modified: trunk/abcl/src/org/armedbear/lisp/Do.java Modified: trunk/abcl/src/org/armedbear/lisp/Do.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Do.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Do.java Sat Feb 13 14:20:48 2010 @@ -35,180 +35,156 @@ import static org.armedbear.lisp.Lisp.*; -public final class Do -{ - // ### do - private static final SpecialOperator DO = new sf_do(); - private static final class sf_do extends SpecialOperator { - sf_do() - { - super(Symbol.DO, "varlist endlist &body body"); - } - - @Override - public LispObject execute(LispObject args, Environment env) - - { - return _do(args, env, false); - } +public final class Do { + // ### do + private static final SpecialOperator DO = new sf_do(); + private static final class sf_do extends SpecialOperator { + sf_do() { + super(Symbol.DO, "varlist endlist &body body"); + } + + @Override + public LispObject execute(LispObject args, Environment env) + + { + return _do(args, env, false); + } }; - // ### do* - private static final SpecialOperator DO_STAR = new sf_do_star(); - private static final class sf_do_star extends SpecialOperator { - sf_do_star() - { - super(Symbol.DO_STAR, "varlist endlist &body body"); - } - - @Override - public LispObject execute(LispObject args, Environment env) - - { - return _do(args, env, true); - } + // ### do* + private static final SpecialOperator DO_STAR = new sf_do_star(); + private static final class sf_do_star extends SpecialOperator { + sf_do_star() { + super(Symbol.DO_STAR, "varlist endlist &body body"); + } + + @Override + public LispObject execute(LispObject args, Environment env) + + { + return _do(args, env, true); + } }; - private static final LispObject _do(LispObject args, Environment env, - boolean sequential) + private static final LispObject _do(LispObject args, Environment env, + boolean sequential) - { - LispObject varlist = args.car(); - LispObject second = args.cadr(); - LispObject end_test_form = second.car(); - LispObject result_forms = second.cdr(); - LispObject body = args.cddr(); - // Process variable specifications. - final int numvars = varlist.length(); - Symbol[] vars = new Symbol[numvars]; - LispObject[] initforms = new LispObject[numvars]; - LispObject[] stepforms = new LispObject[numvars]; - for (int i = 0; i < numvars; i++) - { - final LispObject varspec = varlist.car(); - if (varspec instanceof Cons) - { - vars[i] = checkSymbol(varspec.car()); - initforms[i] = varspec.cadr(); - // Is there a step form? - if (varspec.cddr() != NIL) - stepforms[i] = varspec.caddr(); - } - else - { - // Not a cons, must be a symbol. - vars[i] = checkSymbol(varspec); - initforms[i] = NIL; - } - varlist = varlist.cdr(); - } - final LispThread thread = LispThread.currentThread(); - final SpecialBindingsMark mark = thread.markSpecialBindings(); - // Process declarations. - - final LispObject bodyAndDecls = parseBody(body, false); - LispObject specials = parseSpecials(bodyAndDecls.NTH(1)); - body = bodyAndDecls.car(); - - Environment ext = new Environment(env); - for (int i = 0; i < numvars; i++) - { - Symbol var = vars[i]; - LispObject value = eval(initforms[i], (sequential ? ext : env), thread); - ext = new Environment(ext); - if (specials != NIL && memq(var, specials)) - thread.bindSpecial(var, value); - else if (var.isSpecialVariable()) - thread.bindSpecial(var, value); - else - ext.bind(var, value); - } - LispObject list = specials; - while (list != NIL) - { - ext.declareSpecial(checkSymbol(list.car())); - list = list.cdr(); - } - // Look for tags. - LispObject localTags = preprocessTagBody(body, ext); - LispObject blockId = new LispObject(); - try - { - // Implicit block. - ext.addBlock(NIL, blockId); - while (true) - { - // Execute body. - // Test for termination. - if (eval(end_test_form, ext, thread) != NIL) - break; - - processTagBody(body, localTags, ext); - - // Update variables. - if (sequential) - { - for (int i = 0; i < numvars; i++) - { - LispObject step = stepforms[i]; - if (step != null) - { - Symbol symbol = vars[i]; - LispObject value = eval(step, ext, thread); - if (symbol.isSpecialVariable() - || ext.isDeclaredSpecial(symbol)) - thread.rebindSpecial(symbol, value); - else - ext.rebind(symbol, value); - } - } - } + { + LispObject varlist = args.car(); + LispObject second = args.cadr(); + LispObject end_test_form = second.car(); + LispObject result_forms = second.cdr(); + LispObject body = args.cddr(); + // Process variable specifications. + final int numvars = varlist.length(); + Symbol[] vars = new Symbol[numvars]; + LispObject[] initforms = new LispObject[numvars]; + LispObject[] stepforms = new LispObject[numvars]; + for (int i = 0; i < numvars; i++) { + final LispObject varspec = varlist.car(); + if (varspec instanceof Cons) { + vars[i] = checkSymbol(varspec.car()); + initforms[i] = varspec.cadr(); + // Is there a step form? + if (varspec.cddr() != NIL) + stepforms[i] = varspec.caddr(); + } else { + // Not a cons, must be a symbol. + vars[i] = checkSymbol(varspec); + initforms[i] = NIL; + } + varlist = varlist.cdr(); + } + final LispThread thread = LispThread.currentThread(); + final SpecialBindingsMark mark = thread.markSpecialBindings(); + // Process declarations. + + final LispObject bodyAndDecls = parseBody(body, false); + LispObject specials = parseSpecials(bodyAndDecls.NTH(1)); + body = bodyAndDecls.car(); + + Environment ext = new Environment(env); + for (int i = 0; i < numvars; i++) { + Symbol var = vars[i]; + LispObject value = eval(initforms[i], (sequential ? ext : env), thread); + ext = new Environment(ext); + if (specials != NIL && memq(var, specials)) + thread.bindSpecial(var, value); + else if (var.isSpecialVariable()) + thread.bindSpecial(var, value); else - { - // Evaluate step forms. - LispObject results[] = new LispObject[numvars]; - for (int i = 0; i < numvars; i++) - { - LispObject step = stepforms[i]; - if (step != null) - { - LispObject result = eval(step, ext, thread); - results[i] = result; - } - } + ext.bind(var, value); + } + LispObject list = specials; + while (list != NIL) { + ext.declareSpecial(checkSymbol(list.car())); + list = list.cdr(); + } + // Look for tags. + LispObject localTags = preprocessTagBody(body, ext); + LispObject blockId = new LispObject(); + try { + // Implicit block. + ext.addBlock(NIL, blockId); + while (true) { + // Execute body. + // Test for termination. + if (eval(end_test_form, ext, thread) != NIL) + break; + + processTagBody(body, localTags, ext); + // Update variables. - for (int i = 0; i < numvars; i++) - { - if (results[i] != null) - { - Symbol symbol = vars[i]; - LispObject value = results[i]; - if (symbol.isSpecialVariable() - || ext.isDeclaredSpecial(symbol)) - thread.rebindSpecial(symbol, value); - else - ext.rebind(symbol, value); - } - } - } - if (interrupted) - handleInterrupt(); - } - LispObject result = progn(result_forms, ext, thread); - return result; - } - catch (Return ret) - { - if (ret.getBlock() == blockId) - { - return ret.getResult(); - } - throw ret; - } - finally - { - thread.resetSpecialBindings(mark); - ext.inactive = true; - } - } + if (sequential) { + for (int i = 0; i < numvars; i++) { + LispObject step = stepforms[i]; + if (step != null) { + Symbol symbol = vars[i]; + LispObject value = eval(step, ext, thread); + if (symbol.isSpecialVariable() + || ext.isDeclaredSpecial(symbol)) + thread.rebindSpecial(symbol, value); + else + ext.rebind(symbol, value); + } + } + } else { + // Evaluate step forms. + LispObject results[] = new LispObject[numvars]; + for (int i = 0; i < numvars; i++) { + LispObject step = stepforms[i]; + if (step != null) { + LispObject result = eval(step, ext, thread); + results[i] = result; + } + } + // Update variables. + for (int i = 0; i < numvars; i++) { + if (results[i] != null) { + Symbol symbol = vars[i]; + LispObject value = results[i]; + if (symbol.isSpecialVariable() + || ext.isDeclaredSpecial(symbol)) + thread.rebindSpecial(symbol, value); + else + ext.rebind(symbol, value); + } + } + } + if (interrupted) + handleInterrupt(); + } + LispObject result = progn(result_forms, ext, thread); + return result; + } catch (Return ret) { + if (ret.getBlock() == blockId) { + return ret.getResult(); + } + throw ret; + } + finally { + thread.resetSpecialBindings(mark); + ext.inactive = true; + } + } } From ehuelsmann at common-lisp.net Sat Feb 13 21:43:19 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 13 Feb 2010 16:43:19 -0500 Subject: [armedbear-cvs] r12461 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Feb 13 16:43:16 2010 New Revision: 12461 Log: In the category of making things readable: readable class cast exceptions for NULL and UNBOUND values. 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 Sat Feb 13 16:43:16 2010 @@ -2619,23 +2619,25 @@ public static final Symbol _COMPILE_FILE_ENVIRONMENT_ = exportSpecial("*COMPILE-FILE-ENVIRONMENT*", PACKAGE_SYS, NIL); - public static final LispObject UNBOUND_VALUE = new LispObject() + public static final LispObject UNBOUND_VALUE = new unboundValue(); + private static class unboundValue extends LispObject + { + @Override + public String writeToString() { - @Override - public String writeToString() - { - return "#"; - } - }; + return "#"; + } + } - public static final LispObject NULL_VALUE = new LispObject() + public static final LispObject NULL_VALUE = new nullValue(); + private static class nullValue extends LispObject + { + @Override + public String writeToString() { - @Override - public String writeToString() - { - return "null"; - } - }; + return "null"; + } + } public static final Symbol _SLOT_UNBOUND_ = exportConstant("+SLOT-UNBOUND+", PACKAGE_SYS, UNBOUND_VALUE); From ehuelsmann at common-lisp.net Sat Feb 13 22:16:57 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 13 Feb 2010 17:16:57 -0500 Subject: [armedbear-cvs] r12462 - branches/metaclass/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Feb 13 17:16:55 2010 New Revision: 12462 Log: In order to make StandardClass use its NAME slot instead of LispClass's 'symbol' field: - Rename 'symbol' to 'name', making it private - Rename the 'symbol' java property accessors everywhere - Add getName() / setName() overrides in StandardClass which write to the slot instead of the field Modified: branches/metaclass/abcl/src/org/armedbear/lisp/BuiltInClass.java branches/metaclass/abcl/src/org/armedbear/lisp/Condition.java branches/metaclass/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java branches/metaclass/abcl/src/org/armedbear/lisp/StandardGenericFunction.java branches/metaclass/abcl/src/org/armedbear/lisp/StandardMethod.java branches/metaclass/abcl/src/org/armedbear/lisp/StandardObject.java branches/metaclass/abcl/src/org/armedbear/lisp/StructureClass.java branches/metaclass/abcl/src/org/armedbear/lisp/StructureObject.java branches/metaclass/abcl/src/org/armedbear/lisp/make_condition.java Modified: branches/metaclass/abcl/src/org/armedbear/lisp/BuiltInClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/BuiltInClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/BuiltInClass.java Sat Feb 13 17:16:55 2010 @@ -74,7 +74,7 @@ public String writeToString() { StringBuilder sb = new StringBuilder("#'); return sb.toString(); } Modified: branches/metaclass/abcl/src/org/armedbear/lisp/Condition.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/Condition.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/Condition.java Sat Feb 13 17:16:55 2010 @@ -139,7 +139,7 @@ { LispClass c = getLispClass(); if (c != null) - return c.getSymbol(); + return c.getName(); return Symbol.CONDITION; } Modified: branches/metaclass/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java Sat Feb 13 17:16:55 2010 @@ -69,9 +69,9 @@ { StringBuffer sb = new StringBuffer(Symbol.FORWARD_REFERENCED_CLASS.writeToString()); - if (symbol != null) { + if (getName() != null) { sb.append(' '); - sb.append(symbol.writeToString()); + sb.append(getName().writeToString()); } return unreadableString(sb.toString()); } Modified: branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java Sat Feb 13 17:16:55 2010 @@ -88,7 +88,7 @@ private final int sxhash; - protected Symbol symbol; + private LispObject name; private LispObject propertyList; private Layout classLayout; private LispObject directSuperclasses = NIL; @@ -104,12 +104,16 @@ sxhash = hashCode() & 0x7fffffff; } + protected LispClass(Symbol symbol) + { + this(null, symbol); + } + protected LispClass(Layout layout, Symbol symbol) { super(layout, layout == null ? 0 : layout.getLength()); + setName(symbol); sxhash = hashCode() & 0x7fffffff; - this.symbol = symbol; - this.directSuperclasses = NIL; } protected LispClass(Layout layout, @@ -117,7 +121,7 @@ { super(layout, layout == null ? 0 : layout.getLength()); sxhash = hashCode() & 0x7fffffff; - this.symbol = symbol; + setName(symbol); this.directSuperclasses = directSuperclasses; } @@ -125,7 +129,7 @@ public LispObject getParts() { LispObject result = NIL; - result = result.push(new Cons("NAME", symbol != null ? symbol : NIL)); + result = result.push(new Cons("NAME", name != null ? name : NIL)); result = result.push(new Cons("LAYOUT", classLayout != null ? classLayout : NIL)); result = result.push(new Cons("DIRECT-SUPERCLASSES", directSuperclasses)); result = result.push(new Cons("DIRECT-SUBCLASSES", directSubclasses)); @@ -141,9 +145,14 @@ return sxhash; } - public final Symbol getSymbol() + public LispObject getName() { - return symbol; + return name; + } + + public void setName(LispObject name) + { + this.name = name; } @Override @@ -290,11 +299,6 @@ list(obj1, obj2, obj3, obj4, obj5, obj6, obj7, obj8, obj9); } - public String getName() - { - return symbol.getName(); - } - @Override public LispObject typeOf() { Modified: branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java Sat Feb 13 17:16:55 2010 @@ -5132,7 +5132,7 @@ @Override public LispObject execute(LispObject arg) { - return checkClass(arg).symbol; + return checkClass(arg).getName(); } }; @@ -5144,7 +5144,7 @@ public LispObject execute(LispObject first, LispObject second) { - checkClass(first).symbol = checkSymbol(second); + checkClass(first).setName(checkSymbol(second)); return second; } }; Modified: branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java Sat Feb 13 17:16:55 2010 @@ -47,6 +47,13 @@ super(layout); } + public SlotClass(Symbol symbol, LispObject directSuperclasses) + + + { + this(null, symbol, directSuperclasses); + } + public SlotClass(Layout layout, Symbol symbol, LispObject directSuperclasses) { Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java Sat Feb 13 17:16:55 2010 @@ -38,9 +38,11 @@ public class StandardClass extends SlotClass { + private static Symbol name = PACKAGE_MOP.intern("NAME"); + static Layout layoutStandardClass = new Layout(null, - list(PACKAGE_MOP.intern("NAME"), + list(name, PACKAGE_MOP.intern("LAYOUT"), PACKAGE_MOP.intern("DIRECT-SUPERCLASSES"), PACKAGE_MOP.intern("DIRECT-SUBCLASSES"), @@ -68,7 +70,19 @@ public StandardClass(Symbol symbol, LispObject directSuperclasses) { super(layoutStandardClass, - symbol, directSuperclasses); + symbol, directSuperclasses); + } + + @Override + public LispObject getName() + { + return getInstanceSlotValue(name); + } + + @Override + public void setName(LispObject newName) + { + setInstanceSlotValue(name, newName); } @Override @@ -106,10 +120,10 @@ { StringBuilder sb = new StringBuilder(Symbol.STANDARD_CLASS.writeToString()); - if (symbol != null) + if (getName() != null) { sb.append(' '); - sb.append(symbol.writeToString()); + sb.append(getName().writeToString()); } return unreadableString(sb.toString()); } @@ -295,6 +309,7 @@ STANDARD_OBJECT.setDirectSuperclass(BuiltInClass.CLASS_T); GENERIC_FUNCTION.setDirectSuperclasses(list(BuiltInClass.FUNCTION, STANDARD_OBJECT)); + // GENERIC_FUNCTION.setSlots(); ARITHMETIC_ERROR.setCPL(ARITHMETIC_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); @@ -305,8 +320,10 @@ list(PACKAGE_CL.intern("ARITHMETIC-ERROR-OPERANDS"))))); BUILT_IN_CLASS.setCPL(BUILT_IN_CLASS, CLASS, STANDARD_OBJECT, BuiltInClass.CLASS_T); + // BUILT_IN_CLASS.setSlots(); JAVA_CLASS.setCPL(JAVA_CLASS, CLASS, STANDARD_OBJECT, BuiltInClass.CLASS_T); + // JAVA_CLASS.setSlots(); CELL_ERROR.setCPL(CELL_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); CELL_ERROR.setDirectSlotDefinitions( @@ -315,9 +332,11 @@ CLASS.setCPL(CLASS, STANDARD_OBJECT, BuiltInClass.CLASS_T); COMPILER_ERROR.setCPL(COMPILER_ERROR, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); +// COMPILER_ERROR.setSlots(); COMPILER_UNSUPPORTED_FEATURE_ERROR.setCPL(COMPILER_UNSUPPORTED_FEATURE_ERROR, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); +// COMPILER_UNSUPPORTED_FEATURE_ERROR.setSlots(); CONDITION.setCPL(CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); CONDITION.setDirectSlotDefinitions( list(new SlotDefinition(Symbol.FORMAT_CONTROL, @@ -331,9 +350,11 @@ new Environment()))); CONTROL_ERROR.setCPL(CONTROL_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); +// CONTROL_ERROR.setSlots(); DIVISION_BY_ZERO.setCPL(DIVISION_BY_ZERO, ARITHMETIC_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); +// DIVISION_BY_ZERO.setSlots(); END_OF_FILE.setCPL(END_OF_FILE, STREAM_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); ERROR.setCPL(ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StandardGenericFunction.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/StandardGenericFunction.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Sat Feb 13 17:16:55 2010 @@ -209,7 +209,7 @@ if (name != null) { StringBuilder sb = new StringBuilder(); - sb.append(getLispClass().getSymbol().writeToString()); + sb.append(getLispClass().getName().writeToString()); sb.append(' '); sb.append(name.writeToString()); return unreadableString(sb.toString()); Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StandardMethod.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/StandardMethod.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/StandardMethod.java Sat Feb 13 17:16:55 2010 @@ -156,7 +156,7 @@ if (name != null) { StringBuilder sb = new StringBuilder(); - sb.append(getLispClass().getSymbol().writeToString()); + sb.append(getLispClass().getName().writeToString()); sb.append(' '); sb.append(name.writeToString()); LispObject specializers = @@ -169,7 +169,7 @@ { LispObject spec = specs.car(); if (spec instanceof LispClass) - names = names.push(((LispClass)spec).getSymbol()); + names = names.push(((LispClass)spec).getName()); else names = names.push(spec); specs = specs.cdr(); Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StandardObject.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/StandardObject.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/StandardObject.java Sat Feb 13 17:16:55 2010 @@ -113,13 +113,13 @@ final LispClass c1 = layout.getLispClass(); // The proper name of a class is "a symbol that names the class whose // name is that symbol". - final Symbol symbol = c1.getSymbol(); - if (symbol != NIL) + final LispObject name = c1.getName(); + if (name != NIL && name != UNBOUND_VALUE) { // TYPE-OF.9 - final LispObject c2 = LispClass.findClass(symbol); + final LispObject c2 = LispClass.findClass(checkSymbol(name)); if (c2 == c1) - return symbol; + return name; } return c1; } @@ -142,14 +142,14 @@ { if (type == cls) return T; - if (type == cls.getSymbol()) + if (type == cls.getName()) return T; LispObject cpl = cls.getCPL(); while (cpl != NIL) { if (type == cpl.car()) return T; - if (type == ((LispClass)cpl.car()).getSymbol()) + if (type == ((LispClass)cpl.car()).getName()) return T; cpl = cpl.cdr(); } Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StructureClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/StructureClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/StructureClass.java Sat Feb 13 17:16:55 2010 @@ -79,7 +79,7 @@ public String writeToString() { StringBuffer sb = new StringBuffer("#'); return sb.toString(); } Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StructureObject.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/StructureObject.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/StructureObject.java Sat Feb 13 17:16:55 2010 @@ -144,7 +144,7 @@ @Override public LispObject typeOf() { - return structureClass.getSymbol(); + return structureClass.getName(); } @Override @@ -175,7 +175,7 @@ { if (type instanceof StructureClass) return memq(type, structureClass.getCPL()) ? T : NIL; - if (type == structureClass.getSymbol()) + if (type == structureClass.getName()) return T; if (type == Symbol.STRUCTURE_OBJECT) return T; @@ -421,7 +421,7 @@ return stream.getString().getStringValue(); } if (_PRINT_STRUCTURE_.symbolValue(thread) == NIL) - return unreadableString(structureClass.getSymbol().writeToString()); + return unreadableString(structureClass.getName().writeToString()); int maxLevel = Integer.MAX_VALUE; LispObject printLevel = Symbol.PRINT_LEVEL.symbolValue(thread); if (printLevel instanceof Fixnum) @@ -432,7 +432,7 @@ if (currentLevel >= maxLevel && slots.length > 0) return "#"; StringBuilder sb = new StringBuilder("#S("); - sb.append(structureClass.getSymbol().writeToString()); + sb.append(structureClass.getName().writeToString()); if (currentLevel < maxLevel) { LispObject effectiveSlots = structureClass.getSlotDefinitions(); Modified: branches/metaclass/abcl/src/org/armedbear/lisp/make_condition.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/make_condition.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/make_condition.java Sat Feb 13 17:16:55 2010 @@ -52,7 +52,7 @@ if (type instanceof Symbol) symbol = (Symbol) type; else if (type instanceof LispClass) - symbol = ((LispClass)type).getSymbol(); + symbol = checkSymbol(((LispClass)type).getName()); else { // This function only works on symbols and classes. return NIL; From ehuelsmann at common-lisp.net Sat Feb 13 22:20:55 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 13 Feb 2010 17:20:55 -0500 Subject: [armedbear-cvs] r12463 - branches/metaclass/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Feb 13 17:20:54 2010 New Revision: 12463 Log: Remove some cruft left behind experimenting. Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java Sat Feb 13 17:20:54 2010 @@ -309,7 +309,6 @@ STANDARD_OBJECT.setDirectSuperclass(BuiltInClass.CLASS_T); GENERIC_FUNCTION.setDirectSuperclasses(list(BuiltInClass.FUNCTION, STANDARD_OBJECT)); - // GENERIC_FUNCTION.setSlots(); ARITHMETIC_ERROR.setCPL(ARITHMETIC_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); @@ -320,10 +319,8 @@ list(PACKAGE_CL.intern("ARITHMETIC-ERROR-OPERANDS"))))); BUILT_IN_CLASS.setCPL(BUILT_IN_CLASS, CLASS, STANDARD_OBJECT, BuiltInClass.CLASS_T); - // BUILT_IN_CLASS.setSlots(); JAVA_CLASS.setCPL(JAVA_CLASS, CLASS, STANDARD_OBJECT, BuiltInClass.CLASS_T); - // JAVA_CLASS.setSlots(); CELL_ERROR.setCPL(CELL_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); CELL_ERROR.setDirectSlotDefinitions( @@ -332,11 +329,9 @@ CLASS.setCPL(CLASS, STANDARD_OBJECT, BuiltInClass.CLASS_T); COMPILER_ERROR.setCPL(COMPILER_ERROR, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); -// COMPILER_ERROR.setSlots(); COMPILER_UNSUPPORTED_FEATURE_ERROR.setCPL(COMPILER_UNSUPPORTED_FEATURE_ERROR, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); -// COMPILER_UNSUPPORTED_FEATURE_ERROR.setSlots(); CONDITION.setCPL(CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); CONDITION.setDirectSlotDefinitions( list(new SlotDefinition(Symbol.FORMAT_CONTROL, @@ -350,11 +345,9 @@ new Environment()))); CONTROL_ERROR.setCPL(CONTROL_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); -// CONTROL_ERROR.setSlots(); DIVISION_BY_ZERO.setCPL(DIVISION_BY_ZERO, ARITHMETIC_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); -// DIVISION_BY_ZERO.setSlots(); END_OF_FILE.setCPL(END_OF_FILE, STREAM_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); ERROR.setCPL(ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, From ehuelsmann at common-lisp.net Sat Feb 13 22:45:56 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 13 Feb 2010 17:45:56 -0500 Subject: [armedbear-cvs] r12464 - branches/metaclass/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Feb 13 17:45:56 2010 New Revision: 12464 Log: Convert LAYOUT and DIRECT-SUPERCLASSES of STANDARD-CLASS to slots. Modified: branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java Modified: branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java Sat Feb 13 17:45:56 2010 @@ -122,7 +122,7 @@ super(layout, layout == null ? 0 : layout.getLength()); sxhash = hashCode() & 0x7fffffff; setName(symbol); - this.directSuperclasses = directSuperclasses; + setDirectSuperclasses(directSuperclasses); } @Override @@ -130,8 +130,11 @@ { LispObject result = NIL; result = result.push(new Cons("NAME", name != null ? name : NIL)); - result = result.push(new Cons("LAYOUT", classLayout != null ? classLayout : NIL)); - result = result.push(new Cons("DIRECT-SUPERCLASSES", directSuperclasses)); + result = result.push(new Cons("LAYOUT", + getClassLayout() != null + ? getClassLayout() : NIL)); + result = result.push(new Cons("DIRECT-SUPERCLASSES", + getDirectSuperclasses())); result = result.push(new Cons("DIRECT-SUBCLASSES", directSubclasses)); result = result.push(new Cons("CLASS-PRECEDENCE-LIST", classPrecedenceList)); result = result.push(new Cons("DIRECT-METHODS", directMethods)); @@ -171,12 +174,12 @@ propertyList = obj; } - public final Layout getClassLayout() + public Layout getClassLayout() { return classLayout; } - public final void setClassLayout(Layout layout) + public void setClassLayout(Layout layout) { classLayout = layout; } @@ -188,12 +191,12 @@ return layout.getLength(); } - public final LispObject getDirectSuperclasses() + public LispObject getDirectSuperclasses() { return directSuperclasses; } - public final void setDirectSuperclasses(LispObject directSuperclasses) + public void setDirectSuperclasses(LispObject directSuperclasses) { this.directSuperclasses = directSuperclasses; } @@ -211,7 +214,7 @@ // When there's only one direct superclass... public final void setDirectSuperclass(LispObject superclass) { - directSuperclasses = new Cons(superclass); + setDirectSuperclasses(new Cons(superclass)); } public final LispObject getDirectSubclasses() Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java Sat Feb 13 17:45:56 2010 @@ -38,13 +38,16 @@ public class StandardClass extends SlotClass { - private static Symbol name = PACKAGE_MOP.intern("NAME"); + private static Symbol symName = PACKAGE_MOP.intern("NAME"); + private static Symbol symLayout = PACKAGE_MOP.intern("LAYOUT"); + private static Symbol symDirectSuperclasses + = PACKAGE_MOP.intern("DIRECT-SUPERCLASSES"); static Layout layoutStandardClass = new Layout(null, - list(name, - PACKAGE_MOP.intern("LAYOUT"), - PACKAGE_MOP.intern("DIRECT-SUPERCLASSES"), + list(symName, + symLayout, + symDirectSuperclasses, PACKAGE_MOP.intern("DIRECT-SUBCLASSES"), PACKAGE_MOP.intern("CLASS-PRECEDENCE-LIST"), PACKAGE_MOP.intern("DIRECT-METHODS"), @@ -76,16 +79,43 @@ @Override public LispObject getName() { - return getInstanceSlotValue(name); + return getInstanceSlotValue(symName); } @Override public void setName(LispObject newName) { - setInstanceSlotValue(name, newName); + setInstanceSlotValue(symName, newName); } @Override + public Layout getClassLayout() + { + LispObject layout = getInstanceSlotValue(symLayout); + return (layout == UNBOUND_VALUE) ? null : (Layout)layout; + } + + @Override + public void setClassLayout(Layout newLayout) + { + setInstanceSlotValue(symLayout, newLayout); + } + + @Override + public LispObject getDirectSuperclasses() + { + return getInstanceSlotValue(symDirectSuperclasses); + } + + @Override + public void setDirectSuperclasses(LispObject directSuperclasses) + { + setInstanceSlotValue(symDirectSuperclasses, directSuperclasses); + } + + + + @Override public LispObject classOf() { return STANDARD_CLASS; From ehuelsmann at common-lisp.net Sat Feb 13 22:59:06 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 13 Feb 2010 17:59:06 -0500 Subject: [armedbear-cvs] r12465 - branches/metaclass/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Feb 13 17:59:05 2010 New Revision: 12465 Log: Convert DIRECT-SUBCLASSES of STANDARD-CLASS to a slot. Modified: branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java Modified: branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java Sat Feb 13 17:59:05 2010 @@ -135,7 +135,7 @@ ? getClassLayout() : NIL)); result = result.push(new Cons("DIRECT-SUPERCLASSES", getDirectSuperclasses())); - result = result.push(new Cons("DIRECT-SUBCLASSES", directSubclasses)); + result = result.push(new Cons("DIRECT-SUBCLASSES", getDirectSubclasses())); result = result.push(new Cons("CLASS-PRECEDENCE-LIST", classPrecedenceList)); result = result.push(new Cons("DIRECT-METHODS", directMethods)); result = result.push(new Cons("DOCUMENTATION", documentation)); @@ -217,12 +217,12 @@ setDirectSuperclasses(new Cons(superclass)); } - public final LispObject getDirectSubclasses() + public LispObject getDirectSubclasses() { return directSubclasses; } - public final void setDirectSubclasses(LispObject directSubclasses) + public void setDirectSubclasses(LispObject directSubclasses) { this.directSubclasses = directSubclasses; } Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java Sat Feb 13 17:59:05 2010 @@ -42,13 +42,16 @@ private static Symbol symLayout = PACKAGE_MOP.intern("LAYOUT"); private static Symbol symDirectSuperclasses = PACKAGE_MOP.intern("DIRECT-SUPERCLASSES"); + private static Symbol symDirectSubclasses + = PACKAGE_MOP.intern("DIRECT-SUBCLASSES"); + static Layout layoutStandardClass = new Layout(null, list(symName, symLayout, symDirectSuperclasses, - PACKAGE_MOP.intern("DIRECT-SUBCLASSES"), + symDirectSubclasses, PACKAGE_MOP.intern("CLASS-PRECEDENCE-LIST"), PACKAGE_MOP.intern("DIRECT-METHODS"), PACKAGE_MOP.intern("DOCUMENTATION"), @@ -68,12 +71,15 @@ public StandardClass() { super(layoutStandardClass); + setDirectSuperclasses(NIL); + setDirectSubclasses(NIL); } public StandardClass(Symbol symbol, LispObject directSuperclasses) { super(layoutStandardClass, symbol, directSuperclasses); + setDirectSubclasses(NIL); } @Override @@ -113,6 +119,18 @@ setInstanceSlotValue(symDirectSuperclasses, directSuperclasses); } + @Override + public LispObject getDirectSubclasses() + { + return getInstanceSlotValue(symDirectSubclasses); + } + + @Override + public void setDirectSubclasses(LispObject directSubclasses) + { + setInstanceSlotValue(symDirectSubclasses, directSubclasses); + } + @Override From ehuelsmann at common-lisp.net Sat Feb 13 23:15:13 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 13 Feb 2010 18:15:13 -0500 Subject: [armedbear-cvs] r12466 - branches/metaclass/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Feb 13 18:15:11 2010 New Revision: 12466 Log: Instead of 10 class-precedence-list setters, use a single var-arg one. Modified: branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java Modified: branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java Sat Feb 13 18:15:11 2010 @@ -232,76 +232,21 @@ return classPrecedenceList; } - public final void setCPL(LispObject obj1) + public final void setCPL(LispObject... cpl) { - if (obj1 instanceof Cons) + LispObject obj1 = cpl[0]; + if (obj1 instanceof Cons && cpl.length == 1) classPrecedenceList = obj1; else { Debug.assertTrue(obj1 == this); - classPrecedenceList = new Cons(obj1); + LispObject l = NIL; + for (int i = cpl.length; i-- > 0;) + l = new Cons(cpl[i], l); + classPrecedenceList = l; } } - public final void setCPL(LispObject obj1, LispObject obj2) - { - Debug.assertTrue(obj1 == this); - classPrecedenceList = list(obj1, obj2); - } - - public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3) - { - Debug.assertTrue(obj1 == this); - classPrecedenceList = list(obj1, obj2, obj3); - } - - public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3, - LispObject obj4) - { - Debug.assertTrue(obj1 == this); - classPrecedenceList = list(obj1, obj2, obj3, obj4); - } - - public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3, - LispObject obj4, LispObject obj5) - { - Debug.assertTrue(obj1 == this); - classPrecedenceList = list(obj1, obj2, obj3, obj4, obj5); - } - - public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3, - LispObject obj4, LispObject obj5, LispObject obj6) - { - Debug.assertTrue(obj1 == this); - classPrecedenceList = list(obj1, obj2, obj3, obj4, obj5, obj6); - } - - public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3, - LispObject obj4, LispObject obj5, LispObject obj6, - LispObject obj7) - { - Debug.assertTrue(obj1 == this); - classPrecedenceList = list(obj1, obj2, obj3, obj4, obj5, obj6, obj7); - } - - public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3, - LispObject obj4, LispObject obj5, LispObject obj6, - LispObject obj7, LispObject obj8) - { - Debug.assertTrue(obj1 == this); - classPrecedenceList = - list(obj1, obj2, obj3, obj4, obj5, obj6, obj7, obj8); - } - - public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3, - LispObject obj4, LispObject obj5, LispObject obj6, - LispObject obj7, LispObject obj8, LispObject obj9) - { - Debug.assertTrue(obj1 == this); - classPrecedenceList = - list(obj1, obj2, obj3, obj4, obj5, obj6, obj7, obj8, obj9); - } - @Override public LispObject typeOf() { From ehuelsmann at common-lisp.net Sun Feb 14 07:13:32 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Feb 2010 02:13:32 -0500 Subject: [armedbear-cvs] r12467 - branches/metaclass/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Feb 14 02:13:28 2010 New Revision: 12467 Log: Convert CLASS-PRECEDENCE-LIST of STANDARD-CLASS to a slot. Modified: branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java Modified: branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java Sun Feb 14 02:13:28 2010 @@ -227,12 +227,12 @@ this.directSubclasses = directSubclasses; } - public final LispObject getCPL() + public LispObject getCPL() { return classPrecedenceList; } - public final void setCPL(LispObject... cpl) + public void setCPL(LispObject... cpl) { LispObject obj1 = cpl[0]; if (obj1 instanceof Cons && cpl.length == 1) Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java Sun Feb 14 02:13:28 2010 @@ -44,7 +44,8 @@ = PACKAGE_MOP.intern("DIRECT-SUPERCLASSES"); private static Symbol symDirectSubclasses = PACKAGE_MOP.intern("DIRECT-SUBCLASSES"); - + private static Symbol symClassPrecedenceList + = PACKAGE_MOP.intern("CLASS-PRECEDENCE-LIST"); static Layout layoutStandardClass = new Layout(null, @@ -52,7 +53,7 @@ symLayout, symDirectSuperclasses, symDirectSubclasses, - PACKAGE_MOP.intern("CLASS-PRECEDENCE-LIST"), + symClassPrecedenceList, PACKAGE_MOP.intern("DIRECT-METHODS"), PACKAGE_MOP.intern("DOCUMENTATION"), PACKAGE_MOP.intern("DIRECT-SLOTS"), @@ -73,6 +74,10 @@ super(layoutStandardClass); setDirectSuperclasses(NIL); setDirectSubclasses(NIL); + + // because of the assert below, we need to set the slot directly + // and can't use setCPL() + setInstanceSlotValue(symClassPrecedenceList, NIL); } public StandardClass(Symbol symbol, LispObject directSuperclasses) @@ -80,6 +85,10 @@ super(layoutStandardClass, symbol, directSuperclasses); setDirectSubclasses(NIL); + + // because of the assert below, we need to set the slot directly + // and can't use setCPL() + setInstanceSlotValue(symClassPrecedenceList, NIL); } @Override @@ -131,6 +140,28 @@ setInstanceSlotValue(symDirectSubclasses, directSubclasses); } + @Override + public LispObject getCPL() + { + return getInstanceSlotValue(symClassPrecedenceList); + } + + @Override + public void setCPL(LispObject... cpl) + { + LispObject obj1 = cpl[0]; + if (obj1 instanceof Cons && cpl.length == 1) + setInstanceSlotValue(symClassPrecedenceList, obj1); + else + { + Debug.assertTrue(obj1 == this); + LispObject l = NIL; + for (int i = cpl.length; i-- > 0;) + l = new Cons(cpl[i], l); + setInstanceSlotValue(symClassPrecedenceList, l); + } + } + @Override From ehuelsmann at common-lisp.net Sun Feb 14 08:44:28 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Feb 2010 03:44:28 -0500 Subject: [armedbear-cvs] r12468 - branches/metaclass/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Feb 14 03:44:26 2010 New Revision: 12468 Log: Convert classPrecedenceList, directMethods and documentation to java properties. Modified: branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java Modified: branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java Sun Feb 14 03:44:26 2010 @@ -93,9 +93,9 @@ private Layout classLayout; private LispObject directSuperclasses = NIL; private LispObject directSubclasses = NIL; - public LispObject classPrecedenceList = NIL; // FIXME! Should be private! - public LispObject directMethods = NIL; // FIXME! Should be private! - public LispObject documentation = NIL; // FIXME! Should be private! + private LispObject classPrecedenceList = NIL; + private LispObject directMethods = NIL; + private LispObject documentation = NIL; private boolean finalized; protected LispClass(Layout layout) @@ -247,6 +247,26 @@ } } + public LispObject getDirectMethods() + { + return directMethods; + } + + public void setDirectMethods(LispObject methods) + { + directMethods = methods; + } + + public LispObject getDocumentation() + { + return documentation; + } + + public void setDocumentation(LispObject doc) + { + documentation = doc; + } + @Override public LispObject typeOf() { Modified: branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/Primitives.java Sun Feb 14 03:44:26 2010 @@ -5246,7 +5246,7 @@ public LispObject execute(LispObject first, LispObject second) { - checkClass(first).classPrecedenceList = second; + checkClass(first).setCPL(second); return second; } }; @@ -5259,7 +5259,7 @@ public LispObject execute(LispObject arg) { - return checkClass(arg).directMethods; + return checkClass(arg).getDirectMethods(); } }; @@ -5271,7 +5271,7 @@ public LispObject execute(LispObject first, LispObject second) { - checkClass(first).directMethods = second; + checkClass(first).setDirectMethods(second); return second; } }; @@ -5284,7 +5284,7 @@ public LispObject execute(LispObject arg) { - return checkClass(arg).documentation; + return checkClass(arg).getDocumentation(); } }; @@ -5296,7 +5296,7 @@ public LispObject execute(LispObject first, LispObject second) { - checkClass(first).documentation = second; + checkClass(first).setDocumentation(second); return second; } }; From mevenson at common-lisp.net Sun Feb 14 09:07:55 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 14 Feb 2010 04:07:55 -0500 Subject: [armedbear-cvs] r12469 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun Feb 14 04:07:54 2010 New Revision: 12469 Log: Ensure that FILE-ERROR always has a value for PATHNAME. Fixes ANSI LOAD.ERROR.1. Modified: trunk/abcl/src/org/armedbear/lisp/FileError.java trunk/abcl/src/org/armedbear/lisp/Load.java Modified: trunk/abcl/src/org/armedbear/lisp/FileError.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FileError.java (original) +++ trunk/abcl/src/org/armedbear/lisp/FileError.java Sun Feb 14 04:07:54 2010 @@ -69,6 +69,7 @@ super(StandardClass.FILE_ERROR); setFormatControl(message); setFormatArguments(NIL); + setPathname(NIL); } public FileError(String message, LispObject pathname) Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Sun Feb 14 04:07:54 2010 @@ -144,9 +144,9 @@ if (truename == null || truename.equals(NIL)) { if (ifDoesNotExist) { - return error(new FileError("File not found: " + pathname)); + return error(new FileError("File not found.", pathname)); } else { - Debug.trace("Failed to load " + pathname.getNamestring()); + Debug.warn("Failed to load " + pathname.getNamestring()); return NIL; } } From ehuelsmann at common-lisp.net Sun Feb 14 09:23:15 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Feb 2010 04:23:15 -0500 Subject: [armedbear-cvs] r12470 - branches/metaclass/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Feb 14 04:23:14 2010 New Revision: 12470 Log: Check for LISTP instead of CONSP and remove the resulting special case. Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java Sun Feb 14 04:23:14 2010 @@ -74,10 +74,7 @@ super(layoutStandardClass); setDirectSuperclasses(NIL); setDirectSubclasses(NIL); - - // because of the assert below, we need to set the slot directly - // and can't use setCPL() - setInstanceSlotValue(symClassPrecedenceList, NIL); + setCPL(NIL); } public StandardClass(Symbol symbol, LispObject directSuperclasses) @@ -85,10 +82,7 @@ super(layoutStandardClass, symbol, directSuperclasses); setDirectSubclasses(NIL); - - // because of the assert below, we need to set the slot directly - // and can't use setCPL() - setInstanceSlotValue(symClassPrecedenceList, NIL); + setCPL(NIL); } @Override @@ -150,7 +144,7 @@ public void setCPL(LispObject... cpl) { LispObject obj1 = cpl[0]; - if (obj1 instanceof Cons && cpl.length == 1) + if (obj1.listp() && cpl.length == 1) setInstanceSlotValue(symClassPrecedenceList, obj1); else { From vvoutilainen at common-lisp.net Sun Feb 14 13:18:43 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 14 Feb 2010 08:18:43 -0500 Subject: [armedbear-cvs] r12471 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Feb 14 08:18:40 2010 New Revision: 12471 Log: Stack friendliness. Modified: trunk/abcl/src/org/armedbear/lisp/cxr.java Modified: trunk/abcl/src/org/armedbear/lisp/cxr.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/cxr.java (original) +++ trunk/abcl/src/org/armedbear/lisp/cxr.java Sun Feb 14 08:18:40 2010 @@ -38,9 +38,13 @@ public final class cxr { // ### set-car - private static final Primitive SET_CAR = - new Primitive("set-car", PACKAGE_SYS, true) - { + private static final Primitive SET_CAR = new pf_set_car(); + private static final class pf_set_car extends Primitive { + pf_set_car() + { + super("set-car", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -51,9 +55,13 @@ }; // ### set-cdr - private static final Primitive SET_CDR = - new Primitive("set-cdr", PACKAGE_SYS, true) - { + private static final Primitive SET_CDR = new pf_set_cdr(); + private static final class pf_set_cdr extends Primitive { + pf_set_cdr() + { + super("set-cdr", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -64,8 +72,13 @@ }; // ### car - private static final Primitive CAR = new Primitive(Symbol.CAR, "list") - { + private static final Primitive CAR = new pf_car(); + private static final class pf_car extends Primitive { + pf_car() + { + super(Symbol.CAR, "list"); + } + @Override public LispObject execute(LispObject arg) { @@ -74,8 +87,13 @@ }; // ### cdr - private static final Primitive CDR = new Primitive(Symbol.CDR, "list") - { + private static final Primitive CDR = new pf_cdr(); + private static final class pf_cdr extends Primitive { + pf_cdr() + { + super(Symbol.CDR, "list"); + } + @Override public LispObject execute(LispObject arg) { @@ -84,8 +102,13 @@ }; // ### caar - private static final Primitive CAAR = new Primitive(Symbol.CAAR, "list") - { + private static final Primitive CAAR = new pf_caar(); + private static final class pf_caar extends Primitive { + pf_caar() + { + super(Symbol.CAAR, "list"); + } + @Override public LispObject execute(LispObject arg) { @@ -94,8 +117,13 @@ }; // ### cadr - private static final Primitive CADR = new Primitive(Symbol.CADR, "list") - { + private static final Primitive CADR = new pf_cadr(); + private static final class pf_cadr extends Primitive { + pf_cadr() + { + super(Symbol.CADR, "list"); + } + @Override public LispObject execute(LispObject arg) { @@ -104,8 +132,13 @@ }; // ### cdar - private static final Primitive CDAR = new Primitive(Symbol.CDAR, "list") - { + private static final Primitive CDAR = new pf_cdar(); + private static final class pf_cdar extends Primitive { + pf_cdar() + { + super(Symbol.CDAR, "list"); + } + @Override public LispObject execute(LispObject arg) { @@ -114,8 +147,13 @@ }; // ### cddr - private static final Primitive CDDR = new Primitive(Symbol.CDDR, "list") - { + private static final Primitive CDDR = new pf_cddr(); + private static final class pf_cddr extends Primitive { + pf_cddr() + { + super(Symbol.CDDR, "list"); + } + @Override public LispObject execute(LispObject arg) { @@ -124,8 +162,13 @@ }; // ### caddr - private static final Primitive CADDR = new Primitive(Symbol.CADDR, "list") - { + private static final Primitive CADDR = new pf_caddr(); + private static final class pf_caddr extends Primitive { + pf_caddr() + { + super(Symbol.CADDR, "list"); + } + @Override public LispObject execute(LispObject arg) { @@ -134,8 +177,13 @@ }; // ### caadr - private static final Primitive CAADR = new Primitive(Symbol.CAADR, "list") - { + private static final Primitive CAADR = new pf_caadr(); + private static final class pf_caadr extends Primitive { + pf_caadr() + { + super(Symbol.CAADR, "list"); + } + @Override public LispObject execute(LispObject arg) { @@ -144,8 +192,13 @@ }; // ### caaar - private static final Primitive CAAAR = new Primitive(Symbol.CAAAR, "list") - { + private static final Primitive CAAAR = new pf_caaar(); + private static final class pf_caaar extends Primitive { + pf_caaar() + { + super(Symbol.CAAAR, "list"); + } + @Override public LispObject execute(LispObject arg) { @@ -154,8 +207,13 @@ }; // ### cdaar - private static final Primitive CDAAR = new Primitive(Symbol.CDAAR, "list") - { + private static final Primitive CDAAR = new pf_cdaar(); + private static final class pf_cdaar extends Primitive { + pf_cdaar() + { + super(Symbol.CDAAR, "list"); + } + @Override public LispObject execute(LispObject arg) { @@ -164,8 +222,13 @@ }; // ### cddar - private static final Primitive CDDAR = new Primitive(Symbol.CDDAR, "list") - { + private static final Primitive CDDAR = new pf_cddar(); + private static final class pf_cddar extends Primitive { + pf_cddar() + { + super(Symbol.CDDAR, "list"); + } + @Override public LispObject execute(LispObject arg) { @@ -174,8 +237,13 @@ }; // ### cdddr - private static final Primitive CDDDR = new Primitive(Symbol.CDDDR, "list") - { + private static final Primitive CDDDR = new pf_cdddr(); + private static final class pf_cdddr extends Primitive { + pf_cdddr() + { + super(Symbol.CDDDR, "list"); + } + @Override public LispObject execute(LispObject arg) { @@ -184,8 +252,13 @@ }; // ### cadar - private static final Primitive CADAR = new Primitive(Symbol.CADAR, "list") - { + private static final Primitive CADAR = new pf_cadar(); + private static final class pf_cadar extends Primitive { + pf_cadar() + { + super(Symbol.CADAR, "list"); + } + @Override public LispObject execute(LispObject arg) { @@ -194,8 +267,13 @@ }; // ### cdadr - private static final Primitive CDADR = new Primitive(Symbol.CDADR, "list") - { + private static final Primitive CDADR = new pf_cdadr(); + private static final class pf_cdadr extends Primitive { + pf_cdadr() + { + super(Symbol.CDADR, "list"); + } + @Override public LispObject execute(LispObject arg) { @@ -204,8 +282,13 @@ }; // ### first - private static final Primitive FIRST = new Primitive(Symbol.FIRST, "list") - { + private static final Primitive FIRST = new pf_first(); + private static final class pf_first extends Primitive { + pf_first() + { + super(Symbol.FIRST, "list"); + } + @Override public LispObject execute(LispObject arg) { @@ -214,8 +297,13 @@ }; // ### second - private static final Primitive SECOND = new Primitive(Symbol.SECOND, "list") - { + private static final Primitive SECOND = new pf_second(); + private static final class pf_second extends Primitive { + pf_second() + { + super(Symbol.SECOND, "list"); + } + @Override public LispObject execute(LispObject arg) { @@ -224,8 +312,13 @@ }; // ### third - private static final Primitive THIRD = new Primitive(Symbol.THIRD, "list") - { + private static final Primitive THIRD = new pf_third(); + private static final class pf_third extends Primitive { + pf_third() + { + super(Symbol.THIRD, "list"); + } + @Override public LispObject execute(LispObject arg) { @@ -234,8 +327,13 @@ }; // ### fourth - private static final Primitive FOURTH = new Primitive(Symbol.FOURTH, "list") - { + private static final Primitive FOURTH = new pf_fourth(); + private static final class pf_fourth extends Primitive { + pf_fourth() + { + super(Symbol.FOURTH, "list"); + } + @Override public LispObject execute(LispObject arg) { @@ -244,8 +342,13 @@ }; // ### rest - private static final Primitive REST = new Primitive(Symbol.REST, "list") - { + private static final Primitive REST = new pf_rest(); + private static final class pf_rest extends Primitive { + pf_rest() + { + super(Symbol.REST, "list"); + } + @Override public LispObject execute(LispObject arg) { From vvoutilainen at common-lisp.net Sun Feb 14 13:32:12 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 14 Feb 2010 08:32:12 -0500 Subject: [armedbear-cvs] r12472 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Feb 14 08:32:12 2010 New Revision: 12472 Log: Reindentation. Modified: trunk/abcl/src/org/armedbear/lisp/cxr.java Modified: trunk/abcl/src/org/armedbear/lisp/cxr.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/cxr.java (original) +++ trunk/abcl/src/org/armedbear/lisp/cxr.java Sun Feb 14 08:32:12 2010 @@ -35,324 +35,283 @@ import static org.armedbear.lisp.Lisp.*; -public final class cxr -{ - // ### set-car - private static final Primitive SET_CAR = new pf_set_car(); - private static final class pf_set_car extends Primitive { - pf_set_car() - { - super("set-car", PACKAGE_SYS, true); - } - - @Override - public LispObject execute(LispObject first, LispObject second) - - { - first.setCar(second); - return second; - } - }; - - // ### set-cdr - private static final Primitive SET_CDR = new pf_set_cdr(); - private static final class pf_set_cdr extends Primitive { - pf_set_cdr() - { - super("set-cdr", PACKAGE_SYS, true); - } - - @Override - public LispObject execute(LispObject first, LispObject second) - - { - first.setCdr(second); - return second; - } - }; - - // ### car - private static final Primitive CAR = new pf_car(); - private static final class pf_car extends Primitive { - pf_car() - { - super(Symbol.CAR, "list"); - } - - @Override - public LispObject execute(LispObject arg) - { - return arg.car(); - } - }; - - // ### cdr - private static final Primitive CDR = new pf_cdr(); - private static final class pf_cdr extends Primitive { - pf_cdr() - { - super(Symbol.CDR, "list"); - } - - @Override - public LispObject execute(LispObject arg) - { - return arg.cdr(); - } - }; - - // ### caar - private static final Primitive CAAR = new pf_caar(); - private static final class pf_caar extends Primitive { - pf_caar() - { - super(Symbol.CAAR, "list"); - } - - @Override - public LispObject execute(LispObject arg) - { - return arg.car().car(); - } - }; - - // ### cadr - private static final Primitive CADR = new pf_cadr(); - private static final class pf_cadr extends Primitive { - pf_cadr() - { - super(Symbol.CADR, "list"); - } - - @Override - public LispObject execute(LispObject arg) - { - return arg.cadr(); - } - }; - - // ### cdar - private static final Primitive CDAR = new pf_cdar(); - private static final class pf_cdar extends Primitive { - pf_cdar() - { - super(Symbol.CDAR, "list"); - } - - @Override - public LispObject execute(LispObject arg) - { - return arg.car().cdr(); - } - }; - - // ### cddr - private static final Primitive CDDR = new pf_cddr(); - private static final class pf_cddr extends Primitive { - pf_cddr() - { - super(Symbol.CDDR, "list"); - } - - @Override - public LispObject execute(LispObject arg) - { - return arg.cdr().cdr(); - } - }; - - // ### caddr - private static final Primitive CADDR = new pf_caddr(); - private static final class pf_caddr extends Primitive { - pf_caddr() - { - super(Symbol.CADDR, "list"); - } - - @Override - public LispObject execute(LispObject arg) - { - return arg.caddr(); - } - }; - - // ### caadr - private static final Primitive CAADR = new pf_caadr(); - private static final class pf_caadr extends Primitive { - pf_caadr() - { - super(Symbol.CAADR, "list"); - } - - @Override - public LispObject execute(LispObject arg) - { - return arg.cdr().car().car(); - } - }; - - // ### caaar - private static final Primitive CAAAR = new pf_caaar(); - private static final class pf_caaar extends Primitive { - pf_caaar() - { - super(Symbol.CAAAR, "list"); - } - - @Override - public LispObject execute(LispObject arg) - { - return arg.car().car().car(); - } - }; - - // ### cdaar - private static final Primitive CDAAR = new pf_cdaar(); - private static final class pf_cdaar extends Primitive { - pf_cdaar() - { - super(Symbol.CDAAR, "list"); - } - - @Override - public LispObject execute(LispObject arg) - { - return arg.car().car().cdr(); - } - }; - - // ### cddar - private static final Primitive CDDAR = new pf_cddar(); - private static final class pf_cddar extends Primitive { - pf_cddar() - { - super(Symbol.CDDAR, "list"); - } - - @Override - public LispObject execute(LispObject arg) - { - return arg.car().cdr().cdr(); - } - }; - - // ### cdddr - private static final Primitive CDDDR = new pf_cdddr(); - private static final class pf_cdddr extends Primitive { - pf_cdddr() - { - super(Symbol.CDDDR, "list"); - } - - @Override - public LispObject execute(LispObject arg) - { - return arg.cdr().cdr().cdr(); - } - }; - - // ### cadar - private static final Primitive CADAR = new pf_cadar(); - private static final class pf_cadar extends Primitive { - pf_cadar() - { - super(Symbol.CADAR, "list"); - } - - @Override - public LispObject execute(LispObject arg) - { - return arg.car().cdr().car(); - } - }; - - // ### cdadr - private static final Primitive CDADR = new pf_cdadr(); - private static final class pf_cdadr extends Primitive { - pf_cdadr() - { - super(Symbol.CDADR, "list"); - } - - @Override - public LispObject execute(LispObject arg) - { - return arg.cdr().car().cdr(); - } - }; - - // ### first - private static final Primitive FIRST = new pf_first(); - private static final class pf_first extends Primitive { - pf_first() - { - super(Symbol.FIRST, "list"); - } - - @Override - public LispObject execute(LispObject arg) - { - return arg.car(); - } - }; - - // ### second - private static final Primitive SECOND = new pf_second(); - private static final class pf_second extends Primitive { - pf_second() - { - super(Symbol.SECOND, "list"); - } - - @Override - public LispObject execute(LispObject arg) - { - return arg.cadr(); - } - }; - - // ### third - private static final Primitive THIRD = new pf_third(); - private static final class pf_third extends Primitive { - pf_third() - { - super(Symbol.THIRD, "list"); - } - - @Override - public LispObject execute(LispObject arg) - { - return arg.caddr(); - } - }; - - // ### fourth - private static final Primitive FOURTH = new pf_fourth(); - private static final class pf_fourth extends Primitive { - pf_fourth() - { - super(Symbol.FOURTH, "list"); - } - - @Override - public LispObject execute(LispObject arg) - { - return arg.cdr().cdr().cadr(); - } - }; - - // ### rest - private static final Primitive REST = new pf_rest(); - private static final class pf_rest extends Primitive { - pf_rest() - { - super(Symbol.REST, "list"); - } - - @Override - public LispObject execute(LispObject arg) - { - return arg.cdr(); - } +public final class cxr { + // ### set-car + private static final Primitive SET_CAR = new pf_set_car(); + private static final class pf_set_car extends Primitive { + pf_set_car() { + super("set-car", PACKAGE_SYS, true); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + + { + first.setCar(second); + return second; + } + }; + + // ### set-cdr + private static final Primitive SET_CDR = new pf_set_cdr(); + private static final class pf_set_cdr extends Primitive { + pf_set_cdr() { + super("set-cdr", PACKAGE_SYS, true); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + + { + first.setCdr(second); + return second; + } + }; + + // ### car + private static final Primitive CAR = new pf_car(); + private static final class pf_car extends Primitive { + pf_car() { + super(Symbol.CAR, "list"); + } + + @Override + public LispObject execute(LispObject arg) { + return arg.car(); + } + }; + + // ### cdr + private static final Primitive CDR = new pf_cdr(); + private static final class pf_cdr extends Primitive { + pf_cdr() { + super(Symbol.CDR, "list"); + } + + @Override + public LispObject execute(LispObject arg) { + return arg.cdr(); + } + }; + + // ### caar + private static final Primitive CAAR = new pf_caar(); + private static final class pf_caar extends Primitive { + pf_caar() { + super(Symbol.CAAR, "list"); + } + + @Override + public LispObject execute(LispObject arg) { + return arg.car().car(); + } + }; + + // ### cadr + private static final Primitive CADR = new pf_cadr(); + private static final class pf_cadr extends Primitive { + pf_cadr() { + super(Symbol.CADR, "list"); + } + + @Override + public LispObject execute(LispObject arg) { + return arg.cadr(); + } + }; + + // ### cdar + private static final Primitive CDAR = new pf_cdar(); + private static final class pf_cdar extends Primitive { + pf_cdar() { + super(Symbol.CDAR, "list"); + } + + @Override + public LispObject execute(LispObject arg) { + return arg.car().cdr(); + } + }; + + // ### cddr + private static final Primitive CDDR = new pf_cddr(); + private static final class pf_cddr extends Primitive { + pf_cddr() { + super(Symbol.CDDR, "list"); + } + + @Override + public LispObject execute(LispObject arg) { + return arg.cdr().cdr(); + } + }; + + // ### caddr + private static final Primitive CADDR = new pf_caddr(); + private static final class pf_caddr extends Primitive { + pf_caddr() { + super(Symbol.CADDR, "list"); + } + + @Override + public LispObject execute(LispObject arg) { + return arg.caddr(); + } + }; + + // ### caadr + private static final Primitive CAADR = new pf_caadr(); + private static final class pf_caadr extends Primitive { + pf_caadr() { + super(Symbol.CAADR, "list"); + } + + @Override + public LispObject execute(LispObject arg) { + return arg.cdr().car().car(); + } + }; + + // ### caaar + private static final Primitive CAAAR = new pf_caaar(); + private static final class pf_caaar extends Primitive { + pf_caaar() { + super(Symbol.CAAAR, "list"); + } + + @Override + public LispObject execute(LispObject arg) { + return arg.car().car().car(); + } + }; + + // ### cdaar + private static final Primitive CDAAR = new pf_cdaar(); + private static final class pf_cdaar extends Primitive { + pf_cdaar() { + super(Symbol.CDAAR, "list"); + } + + @Override + public LispObject execute(LispObject arg) { + return arg.car().car().cdr(); + } + }; + + // ### cddar + private static final Primitive CDDAR = new pf_cddar(); + private static final class pf_cddar extends Primitive { + pf_cddar() { + super(Symbol.CDDAR, "list"); + } + + @Override + public LispObject execute(LispObject arg) { + return arg.car().cdr().cdr(); + } + }; + + // ### cdddr + private static final Primitive CDDDR = new pf_cdddr(); + private static final class pf_cdddr extends Primitive { + pf_cdddr() { + super(Symbol.CDDDR, "list"); + } + + @Override + public LispObject execute(LispObject arg) { + return arg.cdr().cdr().cdr(); + } + }; + + // ### cadar + private static final Primitive CADAR = new pf_cadar(); + private static final class pf_cadar extends Primitive { + pf_cadar() { + super(Symbol.CADAR, "list"); + } + + @Override + public LispObject execute(LispObject arg) { + return arg.car().cdr().car(); + } + }; + + // ### cdadr + private static final Primitive CDADR = new pf_cdadr(); + private static final class pf_cdadr extends Primitive { + pf_cdadr() { + super(Symbol.CDADR, "list"); + } + + @Override + public LispObject execute(LispObject arg) { + return arg.cdr().car().cdr(); + } + }; + + // ### first + private static final Primitive FIRST = new pf_first(); + private static final class pf_first extends Primitive { + pf_first() { + super(Symbol.FIRST, "list"); + } + + @Override + public LispObject execute(LispObject arg) { + return arg.car(); + } + }; + + // ### second + private static final Primitive SECOND = new pf_second(); + private static final class pf_second extends Primitive { + pf_second() { + super(Symbol.SECOND, "list"); + } + + @Override + public LispObject execute(LispObject arg) { + return arg.cadr(); + } + }; + + // ### third + private static final Primitive THIRD = new pf_third(); + private static final class pf_third extends Primitive { + pf_third() { + super(Symbol.THIRD, "list"); + } + + @Override + public LispObject execute(LispObject arg) { + return arg.caddr(); + } + }; + + // ### fourth + private static final Primitive FOURTH = new pf_fourth(); + private static final class pf_fourth extends Primitive { + pf_fourth() { + super(Symbol.FOURTH, "list"); + } + + @Override + public LispObject execute(LispObject arg) { + return arg.cdr().cdr().cadr(); + } + }; + + // ### rest + private static final Primitive REST = new pf_rest(); + private static final class pf_rest extends Primitive { + pf_rest() { + super(Symbol.REST, "list"); + } + + @Override + public LispObject execute(LispObject arg) { + return arg.cdr(); + } }; } From vvoutilainen at common-lisp.net Sun Feb 14 14:19:09 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 14 Feb 2010 09:19:09 -0500 Subject: [armedbear-cvs] r12473 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Feb 14 09:19:08 2010 New Revision: 12473 Log: Stack friendliness. Modified: trunk/abcl/src/org/armedbear/lisp/StringFunctions.java Modified: trunk/abcl/src/org/armedbear/lisp/StringFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StringFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StringFunctions.java Sun Feb 14 09:19:08 2010 @@ -39,9 +39,13 @@ { // ### %string= // Case sensitive. - private static final Primitive _STRING_EQUAL = - new Primitive("%string=", PACKAGE_SYS, false) - { + private static final Primitive _STRING_EQUAL = new pf__string_equal(); + private static final class pf__string_equal extends Primitive { + pf__string_equal() + { + super("%string=", PACKAGE_SYS, false); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, @@ -82,9 +86,13 @@ // ### %%string= // Case sensitive. - private static final Primitive __STRING_EQUAL = - new Primitive("%%string=", PACKAGE_SYS, false) - { + private static final Primitive __STRING_EQUAL = new pf___string_equal(); + private static final class pf___string_equal extends Primitive { + pf___string_equal() + { + super("%%string=", PACKAGE_SYS, false); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -103,9 +111,13 @@ // ### %string/= // Case sensitive. - private static final Primitive _STRING_NOT_EQUAL = - new Primitive("%string/=", PACKAGE_SYS, true) - { + private static final Primitive _STRING_NOT_EQUAL = new pf__string_not_equal(); + private static final class pf__string_not_equal extends Primitive { + pf__string_not_equal() + { + super("%string/=", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject[] args) { @@ -140,9 +152,13 @@ // ### %string-equal // Case insensitive. - private static final Primitive _STRING_EQUAL_IGNORE_CASE = - new Primitive("%string-equal", PACKAGE_SYS, true) - { + private static final Primitive _STRING_EQUAL_IGNORE_CASE = new pf__string_equal_ignore_case(); + private static final class pf__string_equal_ignore_case extends Primitive { + pf__string_equal_ignore_case() + { + super("%string-equal", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, @@ -175,9 +191,13 @@ // ### %string-not-equal // Case sensitive. - private static final Primitive _STRING_NOT_EQUAL_IGNORE_CASE = - new Primitive("%string-not-equal", PACKAGE_SYS, true) - { + private static final Primitive _STRING_NOT_EQUAL_IGNORE_CASE = new pf__string_not_equal_ignore_case(); + private static final class pf__string_not_equal_ignore_case extends Primitive { + pf__string_not_equal_ignore_case() + { + super("%string-not-equal", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject[] args) { @@ -219,9 +239,13 @@ // ### %string< // Case sensitive. - private static final Primitive _STRING_LESS_THAN = - new Primitive("%string<", PACKAGE_SYS, true) - { + private static final Primitive _STRING_LESS_THAN = new pf__string_less_than(); + private static final class pf__string_less_than extends Primitive { + pf__string_less_than() + { + super("%string<", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject[] args) { @@ -263,9 +287,13 @@ // ### %string<= // Case sensitive. - private static final Primitive _STRING_GREATER_THAN = - new Primitive("%string>", PACKAGE_SYS, true) - { + private static final Primitive _STRING_GREATER_THAN = new pf__string_greater_than(); + private static final class pf__string_greater_than extends Primitive { + pf__string_greater_than() + { + super("%string>", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject[] args) { @@ -305,9 +333,13 @@ // ### %string<= // Case sensitive. - private static final Primitive _STRING_LE = - new Primitive("%string<=", PACKAGE_SYS, true) - { + private static final Primitive _STRING_LE = new pf__string_le(); + private static final class pf__string_le extends Primitive { + pf__string_le() + { + super("%string<=", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject[] args) { @@ -347,9 +379,13 @@ // ### %string<= // Case sensitive. - private static final Primitive _STRING_GE = - new Primitive("%string>=", PACKAGE_SYS, true) - { + private static final Primitive _STRING_GE = new pf__string_ge(); + private static final class pf__string_ge extends Primitive { + pf__string_ge() + { + super("%string>=", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject[] args) { @@ -391,9 +427,13 @@ // ### %string-lessp // Case insensitive. - private static final Primitive _STRING_LESSP = - new Primitive("%string-lessp", PACKAGE_SYS, true) - { + private static final Primitive _STRING_LESSP = new pf__string_lessp(); + private static final class pf__string_lessp extends Primitive { + pf__string_lessp() + { + super("%string-lessp", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject[] args) { @@ -435,9 +475,13 @@ // ### %string-greaterp // Case insensitive. - private static final Primitive _STRING_GREATERP = - new Primitive("%string-greaterp", PACKAGE_SYS, true) - { + private static final Primitive _STRING_GREATERP = new pf__string_greaterp(); + private static final class pf__string_greaterp extends Primitive { + pf__string_greaterp() + { + super("%string-greaterp", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject[] args) { @@ -477,9 +521,13 @@ // ### %string-not-lessp // Case insensitive. - private static final Primitive _STRING_NOT_LESSP = - new Primitive("%string-not-lessp", PACKAGE_SYS, true) - { + private static final Primitive _STRING_NOT_LESSP = new pf__string_not_lessp(); + private static final class pf__string_not_lessp extends Primitive { + pf__string_not_lessp() + { + super("%string-not-lessp", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject[] args) { @@ -521,9 +569,13 @@ // ### %string-not-greaterp // Case insensitive. - private static final Primitive _STRING_NOT_GREATERP = - new Primitive("%string-not-greaterp", PACKAGE_SYS, true) - { + private static final Primitive _STRING_NOT_GREATERP = new pf__string_not_greaterp(); + private static final class pf__string_not_greaterp extends Primitive { + pf__string_not_greaterp() + { + super("%string-not-greaterp", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject[] args) { @@ -562,9 +614,13 @@ }; // ### %string-upcase - private static final Primitive _STRING_UPCASE = - new Primitive("%string-upcase", PACKAGE_SYS, true) - { + private static final Primitive _STRING_UPCASE = new pf__string_upcase(); + private static final class pf__string_upcase extends Primitive { + pf__string_upcase() + { + super("%string-upcase", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) @@ -598,9 +654,13 @@ }; // ### %string-downcase - private static final Primitive _STRING_DOWNCASE = - new Primitive("%string-downcase", PACKAGE_SYS, true) - { + private static final Primitive _STRING_DOWNCASE = new pf__string_downcase(); + private static final class pf__string_downcase extends Primitive { + pf__string_downcase() + { + super("%string-downcase", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) @@ -633,9 +693,13 @@ }; // ### %string-capitalize - private static final Primitive _STRING_CAPITALIZE= - new Primitive("%string-capitalize", PACKAGE_SYS, true) - { + private static final Primitive _STRING_CAPITALIZE = new pf__string_capitalize(); + private static final class pf__string_capitalize extends Primitive { + pf__string_capitalize() + { + super("%string-capitalize", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) @@ -681,9 +745,13 @@ }; // ### %nstring-upcase - private static final Primitive _NSTRING_UPCASE = - new Primitive("%nstring-upcase", PACKAGE_SYS, true) - { + private static final Primitive _NSTRING_UPCASE = new pf__nstring_upcase(); + private static final class pf__nstring_upcase extends Primitive { + pf__nstring_upcase() + { + super("%nstring-upcase", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) @@ -710,9 +778,13 @@ }; // ### %nstring-downcase - private static final Primitive _NSTRING_DOWNCASE = - new Primitive("%nstring-downcase", PACKAGE_SYS, true) - { + private static final Primitive _NSTRING_DOWNCASE = new pf__nstring_downcase(); + private static final class pf__nstring_downcase extends Primitive { + pf__nstring_downcase() + { + super("%nstring-downcase", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) @@ -739,9 +811,13 @@ }; // ### %nstring-capitalize - private static final Primitive _NSTRING_CAPITALIZE = - new Primitive("%nstring-capitalize", PACKAGE_SYS, true) - { + private static final Primitive _NSTRING_CAPITALIZE = new pf__nstring_capitalize(); + private static final class pf__nstring_capitalize extends Primitive { + pf__nstring_capitalize() + { + super("%nstring-capitalize", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) @@ -780,8 +856,13 @@ }; // ### stringp - public static final Primitive STRINGP = new Primitive("stringp", "object") - { + public static final Primitive STRINGP = new pf_stringp(); + private static final class pf_stringp extends Primitive { + pf_stringp() + { + super("stringp", "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -790,9 +871,13 @@ }; // ### simple-string-p - public static final Primitive SIMPLE_STRING_P = - new Primitive("simple-string-p", "object") - { + public static final Primitive SIMPLE_STRING_P = new pf_simple_string_p(); + private static final class pf_simple_string_p extends Primitive { + pf_simple_string_p() + { + super("simple-string-p", "object"); + } + @Override public LispObject execute(LispObject arg) { @@ -803,9 +888,13 @@ // ### %make-string // %make-string size initial-element element-type => string // Returns a simple string. - private static final Primitive _MAKE_STRING = - new Primitive("%make-string", PACKAGE_SYS, false) - { + private static final Primitive _MAKE_STRING = new pf__make_string(); + private static final class pf__make_string extends Primitive { + pf__make_string() + { + super("%make-string", PACKAGE_SYS, false); + } + @Override public LispObject execute(LispObject size, LispObject initialElement, LispObject elementType) @@ -837,9 +926,13 @@ }; // ### char - private static final Primitive CHAR = - new Primitive(Symbol.CHAR, "string index") - { + private static final Primitive CHAR = new pf_char(); + private static final class pf_char extends Primitive { + pf_char() + { + super(Symbol.CHAR, "string index"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -849,9 +942,13 @@ }; // ### schar - private static final Primitive SCHAR = - new Primitive(Symbol.SCHAR, "string index") - { + private static final Primitive SCHAR = new pf_schar(); + private static final class pf_schar extends Primitive { + pf_schar() + { + super(Symbol.SCHAR, "string index"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -861,9 +958,13 @@ }; // ### set-char - private static final Primitive SET_CHAR = - new Primitive(Symbol.SET_CHAR, "string index character") - { + private static final Primitive SET_CHAR = new pf_set_char(); + private static final class pf_set_char extends Primitive { + pf_set_char() + { + super(Symbol.SET_CHAR, "string index character"); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) @@ -876,9 +977,13 @@ }; // ### set-schar - private static final Primitive SET_SCHAR = - new Primitive(Symbol.SET_SCHAR, "string index character") - { + private static final Primitive SET_SCHAR = new pf_set_schar(); + private static final class pf_set_schar extends Primitive { + pf_set_schar() + { + super(Symbol.SET_SCHAR, "string index character"); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) @@ -894,9 +999,13 @@ }; // ### string-position - private static final Primitive STRING_POSITION = - new Primitive("string-position", PACKAGE_EXT, true) - { + private static final Primitive STRING_POSITION = new pf_string_position(); + private static final class pf_string_position extends Primitive { + pf_string_position() + { + super("string-position", PACKAGE_EXT, true); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) @@ -914,9 +1023,13 @@ }; // ### string-find - private static final Primitive STRING_FIND = - new Primitive("string-find", PACKAGE_EXT, true, "char string") - { + private static final Primitive STRING_FIND = new pf_string_find(); + private static final class pf_string_find extends Primitive { + pf_string_find() + { + super("string-find", PACKAGE_EXT, true, "char string"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -936,9 +1049,13 @@ // ### simple-string-search pattern string => position // Searches string for a substring that matches pattern. - private static final Primitive SIMPLE_STRING_SEARCH = - new Primitive("simple-string-search", PACKAGE_EXT, true) - { + private static final Primitive SIMPLE_STRING_SEARCH = new pf_simple_string_search(); + private static final class pf_simple_string_search extends Primitive { + pf_simple_string_search() + { + super("simple-string-search", PACKAGE_EXT, true); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -950,9 +1067,13 @@ }; // ### simple-string-fill string character => string - private static final Primitive STRING_FILL = - new Primitive("simple-string-fill", PACKAGE_EXT, true) - { + private static final Primitive STRING_FILL = new pf_string_fill(); + private static final class pf_string_fill extends Primitive { + pf_string_fill() + { + super("simple-string-fill", PACKAGE_EXT, true); + } + @Override public LispObject execute(LispObject first, LispObject second) From vvoutilainen at common-lisp.net Sun Feb 14 15:14:42 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 14 Feb 2010 10:14:42 -0500 Subject: [armedbear-cvs] r12474 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Feb 14 10:14:40 2010 New Revision: 12474 Log: Reindentation. Modified: trunk/abcl/src/org/armedbear/lisp/StringFunctions.java Modified: trunk/abcl/src/org/armedbear/lisp/StringFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StringFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StringFunctions.java Sun Feb 14 10:14:40 2010 @@ -35,17 +35,15 @@ import static org.armedbear.lisp.Lisp.*; -public final class StringFunctions -{ +public final class StringFunctions { // ### %string= // Case sensitive. private static final Primitive _STRING_EQUAL = new pf__string_equal(); - private static final class pf__string_equal extends Primitive { - pf__string_equal() - { - super("%string=", PACKAGE_SYS, false); - } - + private static final class pf__string_equal extends Primitive { + pf__string_equal() { + super("%string=", PACKAGE_SYS, false); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, @@ -74,8 +72,7 @@ if (array1[i] != array2[j]) return NIL; } - } - catch (ArrayIndexOutOfBoundsException e) { + } catch (ArrayIndexOutOfBoundsException e) { // Shouldn't happen. Debug.trace(e); return NIL; @@ -87,12 +84,11 @@ // ### %%string= // Case sensitive. private static final Primitive __STRING_EQUAL = new pf___string_equal(); - private static final class pf___string_equal extends Primitive { - pf___string_equal() - { - super("%%string=", PACKAGE_SYS, false); - } - + private static final class pf___string_equal extends Primitive { + pf___string_equal() { + super("%%string=", PACKAGE_SYS, false); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -112,15 +108,13 @@ // ### %string/= // Case sensitive. private static final Primitive _STRING_NOT_EQUAL = new pf__string_not_equal(); - private static final class pf__string_not_equal extends Primitive { - pf__string_not_equal() - { - super("%string/=", PACKAGE_SYS, true); - } - + private static final class pf__string_not_equal extends Primitive { + pf__string_not_equal() { + super("%string/=", PACKAGE_SYS, true); + } + @Override - public LispObject execute(LispObject[] args) - { + public LispObject execute(LispObject[] args) { if (args.length != 6) return error(new WrongNumberOfArgumentsException(this)); char[] array1 = args[0].STRING().getStringChars(); @@ -153,12 +147,11 @@ // ### %string-equal // Case insensitive. private static final Primitive _STRING_EQUAL_IGNORE_CASE = new pf__string_equal_ignore_case(); - private static final class pf__string_equal_ignore_case extends Primitive { - pf__string_equal_ignore_case() - { - super("%string-equal", PACKAGE_SYS, true); - } - + private static final class pf__string_equal_ignore_case extends Primitive { + pf__string_equal_ignore_case() { + super("%string-equal", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, @@ -192,15 +185,13 @@ // ### %string-not-equal // Case sensitive. private static final Primitive _STRING_NOT_EQUAL_IGNORE_CASE = new pf__string_not_equal_ignore_case(); - private static final class pf__string_not_equal_ignore_case extends Primitive { - pf__string_not_equal_ignore_case() - { - super("%string-not-equal", PACKAGE_SYS, true); - } - + private static final class pf__string_not_equal_ignore_case extends Primitive { + pf__string_not_equal_ignore_case() { + super("%string-not-equal", PACKAGE_SYS, true); + } + @Override - public LispObject execute(LispObject[] args) - { + public LispObject execute(LispObject[] args) { if (args.length != 6) return error(new WrongNumberOfArgumentsException(this)); char[] array1 = args[0].STRING().getStringChars(); @@ -225,9 +216,8 @@ char c1 = array1[i]; char c2 = array2[j]; if (c1 == c2 || - LispCharacter.toUpperCase(c1) == LispCharacter.toUpperCase(c2) || - LispCharacter.toLowerCase(c1) == LispCharacter.toLowerCase(c2)) - { + LispCharacter.toUpperCase(c1) == LispCharacter.toUpperCase(c2) || + LispCharacter.toLowerCase(c1) == LispCharacter.toLowerCase(c2)) { ++i; ++j; continue; @@ -240,15 +230,13 @@ // ### %string< // Case sensitive. private static final Primitive _STRING_LESS_THAN = new pf__string_less_than(); - private static final class pf__string_less_than extends Primitive { - pf__string_less_than() - { - super("%string<", PACKAGE_SYS, true); - } - + private static final class pf__string_less_than extends Primitive { + pf__string_less_than() { + super("%string<", PACKAGE_SYS, true); + } + @Override - public LispObject execute(LispObject[] args) - { + public LispObject execute(LispObject[] args) { if (args.length != 6) return error(new WrongNumberOfArgumentsException(this)); char[] array1 = args[0].STRING().getStringChars(); @@ -288,15 +276,13 @@ // ### %string<= // Case sensitive. private static final Primitive _STRING_GREATER_THAN = new pf__string_greater_than(); - private static final class pf__string_greater_than extends Primitive { - pf__string_greater_than() - { - super("%string>", PACKAGE_SYS, true); - } - + private static final class pf__string_greater_than extends Primitive { + pf__string_greater_than() { + super("%string>", PACKAGE_SYS, true); + } + @Override - public LispObject execute(LispObject[] args) - { + public LispObject execute(LispObject[] args) { if (args.length != 6) return error(new WrongNumberOfArgumentsException(this)); char[] array1 = args[0].STRING().getStringChars(); @@ -334,15 +320,13 @@ // ### %string<= // Case sensitive. private static final Primitive _STRING_LE = new pf__string_le(); - private static final class pf__string_le extends Primitive { - pf__string_le() - { - super("%string<=", PACKAGE_SYS, true); - } - + private static final class pf__string_le extends Primitive { + pf__string_le() { + super("%string<=", PACKAGE_SYS, true); + } + @Override - public LispObject execute(LispObject[] args) - { + public LispObject execute(LispObject[] args) { if (args.length != 6) return error(new WrongNumberOfArgumentsException(this)); char[] array1 = args[0].STRING().getStringChars(); @@ -380,15 +364,13 @@ // ### %string<= // Case sensitive. private static final Primitive _STRING_GE = new pf__string_ge(); - private static final class pf__string_ge extends Primitive { - pf__string_ge() - { - super("%string>=", PACKAGE_SYS, true); - } - + private static final class pf__string_ge extends Primitive { + pf__string_ge() { + super("%string>=", PACKAGE_SYS, true); + } + @Override - public LispObject execute(LispObject[] args) - { + public LispObject execute(LispObject[] args) { if (args.length != 6) return error(new WrongNumberOfArgumentsException(this)); char[] array1 = args[0].STRING().getStringChars(); @@ -428,15 +410,13 @@ // ### %string-lessp // Case insensitive. private static final Primitive _STRING_LESSP = new pf__string_lessp(); - private static final class pf__string_lessp extends Primitive { - pf__string_lessp() - { - super("%string-lessp", PACKAGE_SYS, true); - } - + private static final class pf__string_lessp extends Primitive { + pf__string_lessp() { + super("%string-lessp", PACKAGE_SYS, true); + } + @Override - public LispObject execute(LispObject[] args) - { + public LispObject execute(LispObject[] args) { if (args.length != 6) return error(new WrongNumberOfArgumentsException(this)); char[] array1 = args[0].STRING().getStringChars(); @@ -476,15 +456,13 @@ // ### %string-greaterp // Case insensitive. private static final Primitive _STRING_GREATERP = new pf__string_greaterp(); - private static final class pf__string_greaterp extends Primitive { - pf__string_greaterp() - { - super("%string-greaterp", PACKAGE_SYS, true); - } - + private static final class pf__string_greaterp extends Primitive { + pf__string_greaterp() { + super("%string-greaterp", PACKAGE_SYS, true); + } + @Override - public LispObject execute(LispObject[] args) - { + public LispObject execute(LispObject[] args) { if (args.length != 6) return error(new WrongNumberOfArgumentsException(this)); char[] array1 = args[0].STRING().getStringChars(); @@ -522,15 +500,13 @@ // ### %string-not-lessp // Case insensitive. private static final Primitive _STRING_NOT_LESSP = new pf__string_not_lessp(); - private static final class pf__string_not_lessp extends Primitive { - pf__string_not_lessp() - { - super("%string-not-lessp", PACKAGE_SYS, true); - } - + private static final class pf__string_not_lessp extends Primitive { + pf__string_not_lessp() { + super("%string-not-lessp", PACKAGE_SYS, true); + } + @Override - public LispObject execute(LispObject[] args) - { + public LispObject execute(LispObject[] args) { if (args.length != 6) return error(new WrongNumberOfArgumentsException(this)); char[] array1 = args[0].STRING().getStringChars(); @@ -570,15 +546,13 @@ // ### %string-not-greaterp // Case insensitive. private static final Primitive _STRING_NOT_GREATERP = new pf__string_not_greaterp(); - private static final class pf__string_not_greaterp extends Primitive { - pf__string_not_greaterp() - { - super("%string-not-greaterp", PACKAGE_SYS, true); - } - + private static final class pf__string_not_greaterp extends Primitive { + pf__string_not_greaterp() { + super("%string-not-greaterp", PACKAGE_SYS, true); + } + @Override - public LispObject execute(LispObject[] args) - { + public LispObject execute(LispObject[] args) { if (args.length != 6) return error(new WrongNumberOfArgumentsException(this)); char[] array1 = args[0].STRING().getStringChars(); @@ -615,12 +589,11 @@ // ### %string-upcase private static final Primitive _STRING_UPCASE = new pf__string_upcase(); - private static final class pf__string_upcase extends Primitive { - pf__string_upcase() - { - super("%string-upcase", PACKAGE_SYS, true); - } - + private static final class pf__string_upcase extends Primitive { + pf__string_upcase() { + super("%string-upcase", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) @@ -655,16 +628,14 @@ // ### %string-downcase private static final Primitive _STRING_DOWNCASE = new pf__string_downcase(); - private static final class pf__string_downcase extends Primitive { - pf__string_downcase() - { - super("%string-downcase", PACKAGE_SYS, true); - } - + private static final class pf__string_downcase extends Primitive { + pf__string_downcase() { + super("%string-downcase", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second, - LispObject third) - { + LispObject third) { LispObject s = first.STRING(); final int length = s.length(); int start = (int) Fixnum.getValue(second); @@ -694,12 +665,11 @@ // ### %string-capitalize private static final Primitive _STRING_CAPITALIZE = new pf__string_capitalize(); - private static final class pf__string_capitalize extends Primitive { - pf__string_capitalize() - { - super("%string-capitalize", PACKAGE_SYS, true); - } - + private static final class pf__string_capitalize extends Primitive { + pf__string_capitalize() { + super("%string-capitalize", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) @@ -746,12 +716,11 @@ // ### %nstring-upcase private static final Primitive _NSTRING_UPCASE = new pf__nstring_upcase(); - private static final class pf__nstring_upcase extends Primitive { - pf__nstring_upcase() - { - super("%nstring-upcase", PACKAGE_SYS, true); - } - + private static final class pf__nstring_upcase extends Primitive { + pf__nstring_upcase() { + super("%nstring-upcase", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) @@ -779,12 +748,11 @@ // ### %nstring-downcase private static final Primitive _NSTRING_DOWNCASE = new pf__nstring_downcase(); - private static final class pf__nstring_downcase extends Primitive { - pf__nstring_downcase() - { - super("%nstring-downcase", PACKAGE_SYS, true); - } - + private static final class pf__nstring_downcase extends Primitive { + pf__nstring_downcase() { + super("%nstring-downcase", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) @@ -812,12 +780,11 @@ // ### %nstring-capitalize private static final Primitive _NSTRING_CAPITALIZE = new pf__nstring_capitalize(); - private static final class pf__nstring_capitalize extends Primitive { - pf__nstring_capitalize() - { - super("%nstring-capitalize", PACKAGE_SYS, true); - } - + private static final class pf__nstring_capitalize extends Primitive { + pf__nstring_capitalize() { + super("%nstring-capitalize", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) @@ -857,30 +824,26 @@ // ### stringp public static final Primitive STRINGP = new pf_stringp(); - private static final class pf_stringp extends Primitive { - pf_stringp() - { - super("stringp", "object"); - } - + private static final class pf_stringp extends Primitive { + pf_stringp() { + super("stringp", "object"); + } + @Override - public LispObject execute(LispObject arg) - { + public LispObject execute(LispObject arg) { return arg.STRINGP(); } }; // ### simple-string-p public static final Primitive SIMPLE_STRING_P = new pf_simple_string_p(); - private static final class pf_simple_string_p extends Primitive { - pf_simple_string_p() - { - super("simple-string-p", "object"); - } - + private static final class pf_simple_string_p extends Primitive { + pf_simple_string_p() { + super("simple-string-p", "object"); + } + @Override - public LispObject execute(LispObject arg) - { + public LispObject execute(LispObject arg) { return arg.SIMPLE_STRING_P(); } }; @@ -889,12 +852,11 @@ // %make-string size initial-element element-type => string // Returns a simple string. private static final Primitive _MAKE_STRING = new pf__make_string(); - private static final class pf__make_string extends Primitive { - pf__make_string() - { - super("%make-string", PACKAGE_SYS, false); - } - + private static final class pf__make_string extends Primitive { + pf__make_string() { + super("%make-string", PACKAGE_SYS, false); + } + @Override public LispObject execute(LispObject size, LispObject initialElement, LispObject elementType) @@ -927,28 +889,26 @@ // ### char private static final Primitive CHAR = new pf_char(); - private static final class pf_char extends Primitive { - pf_char() - { - super(Symbol.CHAR, "string index"); - } - + private static final class pf_char extends Primitive { + pf_char() { + super(Symbol.CHAR, "string index"); + } + @Override public LispObject execute(LispObject first, LispObject second) { - return first.CHAR(Fixnum.getValue(second)); + return first.CHAR(Fixnum.getValue(second)); } }; // ### schar private static final Primitive SCHAR = new pf_schar(); - private static final class pf_schar extends Primitive { - pf_schar() - { - super(Symbol.SCHAR, "string index"); - } - + private static final class pf_schar extends Primitive { + pf_schar() { + super(Symbol.SCHAR, "string index"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -959,31 +919,29 @@ // ### set-char private static final Primitive SET_CHAR = new pf_set_char(); - private static final class pf_set_char extends Primitive { - pf_set_char() - { - super(Symbol.SET_CHAR, "string index character"); - } - + private static final class pf_set_char extends Primitive { + pf_set_char() { + super(Symbol.SET_CHAR, "string index character"); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) { checkString(first).setCharAt(Fixnum.getValue(second), - LispCharacter.getValue(third)); + LispCharacter.getValue(third)); return third; } }; // ### set-schar private static final Primitive SET_SCHAR = new pf_set_schar(); - private static final class pf_set_schar extends Primitive { - pf_set_schar() - { - super(Symbol.SET_SCHAR, "string index character"); - } - + private static final class pf_set_schar extends Primitive { + pf_set_schar() { + super(Symbol.SET_SCHAR, "string index character"); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) @@ -1000,12 +958,11 @@ // ### string-position private static final Primitive STRING_POSITION = new pf_string_position(); - private static final class pf_string_position extends Primitive { - pf_string_position() - { - super("string-position", PACKAGE_EXT, true); - } - + private static final class pf_string_position extends Primitive { + pf_string_position() { + super("string-position", PACKAGE_EXT, true); + } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) @@ -1024,12 +981,11 @@ // ### string-find private static final Primitive STRING_FIND = new pf_string_find(); - private static final class pf_string_find extends Primitive { - pf_string_find() - { - super("string-find", PACKAGE_EXT, true, "char string"); - } - + private static final class pf_string_find extends Primitive { + pf_string_find() { + super("string-find", PACKAGE_EXT, true, "char string"); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -1050,12 +1006,11 @@ // ### simple-string-search pattern string => position // Searches string for a substring that matches pattern. private static final Primitive SIMPLE_STRING_SEARCH = new pf_simple_string_search(); - private static final class pf_simple_string_search extends Primitive { - pf_simple_string_search() - { - super("simple-string-search", PACKAGE_EXT, true); - } - + private static final class pf_simple_string_search extends Primitive { + pf_simple_string_search() { + super("simple-string-search", PACKAGE_EXT, true); + } + @Override public LispObject execute(LispObject first, LispObject second) @@ -1068,17 +1023,16 @@ // ### simple-string-fill string character => string private static final Primitive STRING_FILL = new pf_string_fill(); - private static final class pf_string_fill extends Primitive { - pf_string_fill() - { - super("simple-string-fill", PACKAGE_EXT, true); - } - + private static final class pf_string_fill extends Primitive { + pf_string_fill() { + super("simple-string-fill", PACKAGE_EXT, true); + } + @Override public LispObject execute(LispObject first, LispObject second) { - if(first instanceof AbstractString) { + if (first instanceof AbstractString) { AbstractString s = (AbstractString) first; s.fill(LispCharacter.getValue(second)); return first; @@ -1086,5 +1040,5 @@ return type_error(first, Symbol.SIMPLE_STRING); } }; - + } From ehuelsmann at common-lisp.net Sun Feb 14 16:27:39 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Feb 2010 11:27:39 -0500 Subject: [armedbear-cvs] r12475 - branches/metaclass/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Feb 14 11:27:37 2010 New Revision: 12475 Log: Access the CPL through its accessor *everywhere*. Modified: branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java Modified: branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java Sun Feb 14 11:27:37 2010 @@ -136,7 +136,7 @@ result = result.push(new Cons("DIRECT-SUPERCLASSES", getDirectSuperclasses())); result = result.push(new Cons("DIRECT-SUBCLASSES", getDirectSubclasses())); - result = result.push(new Cons("CLASS-PRECEDENCE-LIST", classPrecedenceList)); + result = result.push(new Cons("CLASS-PRECEDENCE-LIST", getCPL())); result = result.push(new Cons("DIRECT-METHODS", directMethods)); result = result.push(new Cons("DOCUMENTATION", documentation)); return result.nreverse(); @@ -291,7 +291,7 @@ public boolean subclassp(LispObject obj) { - LispObject cpl = classPrecedenceList; + LispObject cpl = getCPL(); while (cpl != NIL) { if (cpl.car() == obj) From ehuelsmann at common-lisp.net Sun Feb 14 18:46:12 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Feb 2010 13:46:12 -0500 Subject: [armedbear-cvs] r12476 - branches/metaclass/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Feb 14 13:46:09 2010 New Revision: 12476 Log: Make DOCUMENTATION and DIRECT-METHODS STANDARD-CLASS slots. Modified: branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java Modified: branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/LispClass.java Sun Feb 14 13:46:09 2010 @@ -137,8 +137,8 @@ getDirectSuperclasses())); result = result.push(new Cons("DIRECT-SUBCLASSES", getDirectSubclasses())); result = result.push(new Cons("CLASS-PRECEDENCE-LIST", getCPL())); - result = result.push(new Cons("DIRECT-METHODS", directMethods)); - result = result.push(new Cons("DOCUMENTATION", documentation)); + result = result.push(new Cons("DIRECT-METHODS", getDirectMethods())); + result = result.push(new Cons("DOCUMENTATION", getDocumentation())); return result.nreverse(); } Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java Sun Feb 14 13:46:09 2010 @@ -46,6 +46,10 @@ = PACKAGE_MOP.intern("DIRECT-SUBCLASSES"); private static Symbol symClassPrecedenceList = PACKAGE_MOP.intern("CLASS-PRECEDENCE-LIST"); + private static Symbol symDirectMethods + = PACKAGE_MOP.intern("DIRECT-METHODS"); + private static Symbol symDocumentation + = PACKAGE_MOP.intern("DOCUMENTATION"); static Layout layoutStandardClass = new Layout(null, @@ -54,8 +58,8 @@ symDirectSuperclasses, symDirectSubclasses, symClassPrecedenceList, - PACKAGE_MOP.intern("DIRECT-METHODS"), - PACKAGE_MOP.intern("DOCUMENTATION"), + symDirectMethods, + symDocumentation, PACKAGE_MOP.intern("DIRECT-SLOTS"), PACKAGE_MOP.intern("SLOTS"), PACKAGE_MOP.intern("DIRECT-DEFAULT-INITARGS"), @@ -75,6 +79,8 @@ setDirectSuperclasses(NIL); setDirectSubclasses(NIL); setCPL(NIL); + setDirectMethods(NIL); + setDocumentation(NIL); } public StandardClass(Symbol symbol, LispObject directSuperclasses) @@ -83,6 +89,8 @@ symbol, directSuperclasses); setDirectSubclasses(NIL); setCPL(NIL); + setDirectMethods(NIL); + setDocumentation(NIL); } @Override @@ -156,6 +164,30 @@ } } + @Override + public LispObject getDirectMethods() + { + return getInstanceSlotValue(symDirectMethods); + } + + @Override + public void setDirectMethods(LispObject methods) + { + setInstanceSlotValue(symDirectMethods, methods); + } + + @Override + public LispObject getDocumentation() + { + return getInstanceSlotValue(symDocumentation); + } + + @Override + public void setDocumentation(LispObject doc) + { + setInstanceSlotValue(symDocumentation, doc); + } + @Override From ehuelsmann at common-lisp.net Sun Feb 14 19:33:39 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Feb 2010 14:33:39 -0500 Subject: [armedbear-cvs] r12477 - branches/metaclass/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Feb 14 14:33:37 2010 New Revision: 12477 Log: SlotClass now accesses its fields only through the accessor functions. Modified: branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java Modified: branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java Sun Feb 14 14:33:37 2010 @@ -64,10 +64,13 @@ public LispObject getParts() { LispObject result = super.getParts().nreverse(); - result = result.push(new Cons("DIRECT-SLOTS", directSlotDefinitions)); - result = result.push(new Cons("SLOTS", slotDefinitions)); - result = result.push(new Cons("DIRECT-DEFAULT-INITARGS", directDefaultInitargs)); - result = result.push(new Cons("DEFAULT-INITARGS", defaultInitargs)); + result = result.push(new Cons("DIRECT-SLOTS", + getDirectSlotDefinitions())); + result = result.push(new Cons("SLOTS", getSlotDefinitions())); + result = result.push(new Cons("DIRECT-DEFAULT-INITARGS", + getDirectDefaultInitargs())); + result = result.push(new Cons("DEFAULT-INITARGS", + getDefaultInitargs())); return result.nreverse(); } @@ -107,6 +110,11 @@ this.directDefaultInitargs = directDefaultInitargs; } + public LispObject getDefaultInitargs() + { + return defaultInitargs; + } + public void setDefaultInitargs(LispObject defaultInitargs) { this.defaultInitargs = defaultInitargs; @@ -133,7 +141,8 @@ if (isFinalized()) return; - Debug.assertTrue(slotDefinitions == NIL); + LispObject defs = getSlotDefinitions(); + Debug.assertTrue(defs == NIL); LispObject cpl = getCPL(); Debug.assertTrue(cpl != null); Debug.assertTrue(cpl.listp()); @@ -142,20 +151,20 @@ LispObject car = cpl.car(); if (car instanceof StandardClass) { StandardClass cls = (StandardClass) car; - LispObject defs = cls.getDirectSlotDefinitions(); - Debug.assertTrue(defs != null); - Debug.assertTrue(defs.listp()); - while (defs != NIL) { - slotDefinitions = slotDefinitions.push(defs.car()); - defs = defs.cdr(); + LispObject directDefs = cls.getDirectSlotDefinitions(); + Debug.assertTrue(directDefs != null); + Debug.assertTrue(directDefs.listp()); + while (directDefs != NIL) { + defs = defs.push(directDefs.car()); + directDefs = directDefs.cdr(); } } cpl = cpl.cdr(); } - slotDefinitions = slotDefinitions.nreverse(); - LispObject[] instanceSlotNames = new LispObject[slotDefinitions.length()]; + setSlotDefinitions(defs.nreverse()); + LispObject[] instanceSlotNames = new LispObject[defs.length()]; int i = 0; - LispObject tail = slotDefinitions; + LispObject tail = getSlotDefinitions(); while (tail != NIL) { SlotDefinition slotDefinition = (SlotDefinition) tail.car(); slotDefinition.setLocation(i); @@ -176,7 +185,7 @@ { if (arg instanceof SlotClass) - return ((SlotClass)arg).directSlotDefinitions; + return ((SlotClass)arg).getDirectSlotDefinitions(); if (arg instanceof BuiltInClass) return NIL; return type_error(arg, Symbol.STANDARD_CLASS); @@ -192,7 +201,7 @@ { if (first instanceof SlotClass) { - ((SlotClass)first).directSlotDefinitions = second; + ((SlotClass)first).setDirectSlotDefinitions(second); return second; } else { @@ -210,7 +219,7 @@ { if (arg instanceof SlotClass) - return ((SlotClass)arg).slotDefinitions; + return ((SlotClass)arg).getSlotDefinitions(); if (arg instanceof BuiltInClass) return NIL; return type_error(arg, Symbol.STANDARD_CLASS); @@ -225,12 +234,12 @@ public LispObject execute(LispObject first, LispObject second) { - if (first instanceof SlotClass) { - ((SlotClass)first).slotDefinitions = second; - return second; + if (first instanceof SlotClass) { + ((SlotClass)first).setSlotDefinitions(second); + return second; } - else { - return type_error(first, Symbol.STANDARD_CLASS); + else { + return type_error(first, Symbol.STANDARD_CLASS); } } }; @@ -244,7 +253,7 @@ { if (arg instanceof SlotClass) - return ((SlotClass)arg).directDefaultInitargs; + return ((SlotClass)arg).getDirectDefaultInitargs(); if (arg instanceof BuiltInClass) return NIL; return type_error(arg, Symbol.STANDARD_CLASS); @@ -259,11 +268,11 @@ public LispObject execute(LispObject first, LispObject second) { - if (first instanceof SlotClass) { - ((SlotClass)first).directDefaultInitargs = second; - return second; - } - return type_error(first, Symbol.STANDARD_CLASS); + if (first instanceof SlotClass) { + ((SlotClass)first).setDirectDefaultInitargs(second); + return second; + } + return type_error(first, Symbol.STANDARD_CLASS); } }; @@ -276,7 +285,7 @@ { if (arg instanceof SlotClass) - return ((SlotClass)arg).defaultInitargs; + return ((SlotClass)arg).getDefaultInitargs(); if (arg instanceof BuiltInClass) return NIL; return type_error(arg, Symbol.STANDARD_CLASS); @@ -292,7 +301,7 @@ { if (first instanceof SlotClass) { - ((SlotClass)first).defaultInitargs = second; + ((SlotClass)first).setDefaultInitargs(second); return second; } return type_error(first, Symbol.STANDARD_CLASS); From ehuelsmann at common-lisp.net Sun Feb 14 19:41:21 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Feb 2010 14:41:21 -0500 Subject: [armedbear-cvs] r12478 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Feb 14 14:41:20 2010 New Revision: 12478 Log: loadCompiledFunction is deprecated, so rewrite to eliminate its use. Modified: trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java Modified: trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java (original) +++ trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java Sun Feb 14 14:41:20 2010 @@ -219,8 +219,10 @@ LispThread thread = LispThread.currentThread(); LispObject value = AUTOLOADING_CACHE.symbolValue(thread); - if (value instanceof Nil) - return loadCompiledFunction(name); + if (value instanceof Nil) { + byte[] bytes = readFunctionBytes(new Pathname(name)); + return (bytes == null) ? null : loadClassBytes(bytes); + } Hashtable cache = (Hashtable)value.javaInstance(); byte[] bytes = (byte[])cache.get(name); From ehuelsmann at common-lisp.net Sun Feb 14 19:54:17 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Feb 2010 14:54:17 -0500 Subject: [armedbear-cvs] r12479 - branches/metaclass/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Feb 14 14:54:17 2010 New Revision: 12479 Log: Slot storage for DIRECT-SLOTS and SLOTS of STANDARD-CLASS. Modified: branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java Modified: branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/SlotClass.java Sun Feb 14 14:54:17 2010 @@ -90,7 +90,7 @@ this.directSlotDefinitions = directSlotDefinitions; } - public final LispObject getSlotDefinitions() + public LispObject getSlotDefinitions() { return slotDefinitions; } Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java Sun Feb 14 14:54:17 2010 @@ -50,6 +50,10 @@ = PACKAGE_MOP.intern("DIRECT-METHODS"); private static Symbol symDocumentation = PACKAGE_MOP.intern("DOCUMENTATION"); + private static Symbol symDirectSlots + = PACKAGE_MOP.intern("DIRECT-SLOTS"); + private static Symbol symSlots + = PACKAGE_MOP.intern("SLOTS"); static Layout layoutStandardClass = new Layout(null, @@ -60,8 +64,8 @@ symClassPrecedenceList, symDirectMethods, symDocumentation, - PACKAGE_MOP.intern("DIRECT-SLOTS"), - PACKAGE_MOP.intern("SLOTS"), + symDirectSlots, + symSlots, PACKAGE_MOP.intern("DIRECT-DEFAULT-INITARGS"), PACKAGE_MOP.intern("DEFAULT-INITARGS")), NIL) @@ -81,6 +85,8 @@ setCPL(NIL); setDirectMethods(NIL); setDocumentation(NIL); + setDirectSlotDefinitions(NIL); + setSlotDefinitions(NIL); } public StandardClass(Symbol symbol, LispObject directSuperclasses) @@ -91,6 +97,8 @@ setCPL(NIL); setDirectMethods(NIL); setDocumentation(NIL); + setDirectSlotDefinitions(NIL); + setSlotDefinitions(NIL); } @Override @@ -188,6 +196,30 @@ setInstanceSlotValue(symDocumentation, doc); } + @Override + public LispObject getDirectSlotDefinitions() + { + return getInstanceSlotValue(symDirectSlots); + } + + @Override + public void setDirectSlotDefinitions(LispObject directSlotDefinitions) + { + setInstanceSlotValue(symDirectSlots, directSlotDefinitions); + } + + @Override + public LispObject getSlotDefinitions() + { + return getInstanceSlotValue(symSlots); + } + + @Override + public void setSlotDefinitions(LispObject slotDefinitions) + { + setInstanceSlotValue(symSlots, slotDefinitions); + } + @Override From ehuelsmann at common-lisp.net Sun Feb 14 20:08:24 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Feb 2010 15:08:24 -0500 Subject: [armedbear-cvs] r12480 - branches/metaclass/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Feb 14 15:08:23 2010 New Revision: 12480 Log: DIRECT-DEFAULT-INITARGS and DEFAULT-INITARGS slot storage for STANDARD-CLASS. Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java Modified: branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java (original) +++ branches/metaclass/abcl/src/org/armedbear/lisp/StandardClass.java Sun Feb 14 15:08:23 2010 @@ -54,6 +54,10 @@ = PACKAGE_MOP.intern("DIRECT-SLOTS"); private static Symbol symSlots = PACKAGE_MOP.intern("SLOTS"); + private static Symbol symDirectDefaultInitargs + = PACKAGE_MOP.intern("DIRECT-DEFAULT-INITARGS"); + private static Symbol symDefaultInitargs + = PACKAGE_MOP.intern("DEFAULT-INITARGS"); static Layout layoutStandardClass = new Layout(null, @@ -66,8 +70,8 @@ symDocumentation, symDirectSlots, symSlots, - PACKAGE_MOP.intern("DIRECT-DEFAULT-INITARGS"), - PACKAGE_MOP.intern("DEFAULT-INITARGS")), + symDirectDefaultInitargs, + symDefaultInitargs), NIL) { @Override @@ -87,6 +91,8 @@ setDocumentation(NIL); setDirectSlotDefinitions(NIL); setSlotDefinitions(NIL); + setDirectDefaultInitargs(NIL); + setDefaultInitargs(NIL); } public StandardClass(Symbol symbol, LispObject directSuperclasses) @@ -99,6 +105,8 @@ setDocumentation(NIL); setDirectSlotDefinitions(NIL); setSlotDefinitions(NIL); + setDirectDefaultInitargs(NIL); + setDefaultInitargs(NIL); } @Override @@ -220,6 +228,30 @@ setInstanceSlotValue(symSlots, slotDefinitions); } + @Override + public LispObject getDirectDefaultInitargs() + { + return getInstanceSlotValue(symDirectDefaultInitargs); + } + + @Override + public void setDirectDefaultInitargs(LispObject directDefaultInitargs) + { + setInstanceSlotValue(symDirectDefaultInitargs, directDefaultInitargs); + } + + @Override + public LispObject getDefaultInitargs() + { + return getInstanceSlotValue(symDefaultInitargs); + } + + @Override + public void setDefaultInitargs(LispObject defaultInitargs) + { + setInstanceSlotValue(symDefaultInitargs, defaultInitargs); + } + @Override From ehuelsmann at common-lisp.net Sun Feb 14 21:30:01 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Feb 2010 16:30:01 -0500 Subject: [armedbear-cvs] r12481 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Feb 14 16:29:58 2010 New Revision: 12481 Log: Merge 'metaclass' branch, making STANDARD-CLASS have slots to be inherited by deriving metaclasses. Note: this does definitely *not* complete the metaclass work. Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java trunk/abcl/src/org/armedbear/lisp/Condition.java trunk/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java trunk/abcl/src/org/armedbear/lisp/Layout.java trunk/abcl/src/org/armedbear/lisp/LispClass.java trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/SlotClass.java trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java trunk/abcl/src/org/armedbear/lisp/StandardMethod.java trunk/abcl/src/org/armedbear/lisp/StandardObject.java trunk/abcl/src/org/armedbear/lisp/StructureClass.java trunk/abcl/src/org/armedbear/lisp/StructureObject.java trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/make_condition.java Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java Sun Feb 14 16:29:58 2010 @@ -74,7 +74,7 @@ public String writeToString() { StringBuilder sb = new StringBuilder("#'); return sb.toString(); } Modified: trunk/abcl/src/org/armedbear/lisp/Condition.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Condition.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Condition.java Sun Feb 14 16:29:58 2010 @@ -139,7 +139,7 @@ { LispClass c = getLispClass(); if (c != null) - return c.getSymbol(); + return c.getName(); return Symbol.CONDITION; } Modified: trunk/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java Sun Feb 14 16:29:58 2010 @@ -69,9 +69,9 @@ { StringBuffer sb = new StringBuffer(Symbol.FORWARD_REFERENCED_CLASS.writeToString()); - if (symbol != null) { + if (getName() != null) { sb.append(' '); - sb.append(symbol.writeToString()); + sb.append(getName().writeToString()); } return unreadableString(sb.toString()); } 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 Sun Feb 14 16:29:58 2010 @@ -35,9 +35,9 @@ import static org.armedbear.lisp.Lisp.*; -public final class Layout extends LispObject +public class Layout extends LispObject { - public final LispClass lispClass; + private final LispClass lispClass; public final EqHashTable slotTable; private final LispObject[] slotNames; @@ -76,7 +76,7 @@ // Copy constructor. private Layout(Layout oldLayout) { - lispClass = oldLayout.lispClass; + lispClass = oldLayout.getLispClass(); slotNames = oldLayout.slotNames; sharedSlots = oldLayout.sharedSlots; slotTable = initializeSlotTable(slotNames); @@ -94,7 +94,7 @@ public LispObject getParts() { LispObject result = NIL; - result = result.push(new Cons("class", lispClass)); + result = result.push(new Cons("class", getLispClass())); for (int i = 0; i < slotNames.length; i++) { result = result.push(new Cons("slot " + i, slotNames[i])); @@ -103,6 +103,11 @@ return result.nreverse(); } + public LispClass getLispClass() + { + return lispClass; + } + public boolean isInvalid() { return invalid; @@ -167,7 +172,7 @@ @Override public LispObject execute(LispObject arg) { - return checkLayout(arg).lispClass; + return checkLayout(arg).getLispClass(); } }; 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 Sun Feb 14 16:29:58 2010 @@ -88,46 +88,57 @@ private final int sxhash; - protected Symbol symbol; + private LispObject name; private LispObject propertyList; private Layout classLayout; private LispObject directSuperclasses = NIL; private LispObject directSubclasses = NIL; - public LispObject classPrecedenceList = NIL; // FIXME! Should be private! - public LispObject directMethods = NIL; // FIXME! Should be private! - public LispObject documentation = NIL; // FIXME! Should be private! + private LispObject classPrecedenceList = NIL; + private LispObject directMethods = NIL; + private LispObject documentation = NIL; private boolean finalized; - protected LispClass() + protected LispClass(Layout layout) { + super(layout, layout == null ? 0 : layout.getLength()); sxhash = hashCode() & 0x7fffffff; } protected LispClass(Symbol symbol) { + this(null, symbol); + } + + protected LispClass(Layout layout, Symbol symbol) + { + super(layout, layout == null ? 0 : layout.getLength()); + setName(symbol); sxhash = hashCode() & 0x7fffffff; - this.symbol = symbol; - this.directSuperclasses = NIL; } - protected LispClass(Symbol symbol, LispObject directSuperclasses) + protected LispClass(Layout layout, + Symbol symbol, LispObject directSuperclasses) { + super(layout, layout == null ? 0 : layout.getLength()); sxhash = hashCode() & 0x7fffffff; - this.symbol = symbol; - this.directSuperclasses = directSuperclasses; + setName(symbol); + setDirectSuperclasses(directSuperclasses); } @Override public LispObject getParts() { LispObject result = NIL; - result = result.push(new Cons("NAME", symbol != null ? symbol : NIL)); - result = result.push(new Cons("LAYOUT", classLayout != null ? classLayout : NIL)); - result = result.push(new Cons("DIRECT-SUPERCLASSES", directSuperclasses)); - result = result.push(new Cons("DIRECT-SUBCLASSES", directSubclasses)); - result = result.push(new Cons("CLASS-PRECEDENCE-LIST", classPrecedenceList)); - result = result.push(new Cons("DIRECT-METHODS", directMethods)); - result = result.push(new Cons("DOCUMENTATION", documentation)); + result = result.push(new Cons("NAME", name != null ? name : NIL)); + result = result.push(new Cons("LAYOUT", + getClassLayout() != null + ? getClassLayout() : NIL)); + result = result.push(new Cons("DIRECT-SUPERCLASSES", + getDirectSuperclasses())); + result = result.push(new Cons("DIRECT-SUBCLASSES", getDirectSubclasses())); + result = result.push(new Cons("CLASS-PRECEDENCE-LIST", getCPL())); + result = result.push(new Cons("DIRECT-METHODS", getDirectMethods())); + result = result.push(new Cons("DOCUMENTATION", getDocumentation())); return result.nreverse(); } @@ -137,9 +148,14 @@ return sxhash; } - public final Symbol getSymbol() + public LispObject getName() { - return symbol; + return name; + } + + public void setName(LispObject name) + { + this.name = name; } @Override @@ -158,12 +174,12 @@ propertyList = obj; } - public final Layout getClassLayout() + public Layout getClassLayout() { return classLayout; } - public final void setClassLayout(Layout layout) + public void setClassLayout(Layout layout) { classLayout = layout; } @@ -175,12 +191,12 @@ return layout.getLength(); } - public final LispObject getDirectSuperclasses() + public LispObject getDirectSuperclasses() { return directSuperclasses; } - public final void setDirectSuperclasses(LispObject directSuperclasses) + public void setDirectSuperclasses(LispObject directSuperclasses) { this.directSuperclasses = directSuperclasses; } @@ -198,97 +214,57 @@ // When there's only one direct superclass... public final void setDirectSuperclass(LispObject superclass) { - directSuperclasses = new Cons(superclass); + setDirectSuperclasses(new Cons(superclass)); } - public final LispObject getDirectSubclasses() + public LispObject getDirectSubclasses() { return directSubclasses; } - public final void setDirectSubclasses(LispObject directSubclasses) + public void setDirectSubclasses(LispObject directSubclasses) { this.directSubclasses = directSubclasses; } - public final LispObject getCPL() + public LispObject getCPL() { return classPrecedenceList; } - public final void setCPL(LispObject obj1) + public void setCPL(LispObject... cpl) { - if (obj1 instanceof Cons) + LispObject obj1 = cpl[0]; + if (obj1 instanceof Cons && cpl.length == 1) classPrecedenceList = obj1; else { Debug.assertTrue(obj1 == this); - classPrecedenceList = new Cons(obj1); + LispObject l = NIL; + for (int i = cpl.length; i-- > 0;) + l = new Cons(cpl[i], l); + classPrecedenceList = l; } } - public final void setCPL(LispObject obj1, LispObject obj2) - { - Debug.assertTrue(obj1 == this); - classPrecedenceList = list(obj1, obj2); - } - - public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3) - { - Debug.assertTrue(obj1 == this); - classPrecedenceList = list(obj1, obj2, obj3); - } - - public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3, - LispObject obj4) - { - Debug.assertTrue(obj1 == this); - classPrecedenceList = list(obj1, obj2, obj3, obj4); - } - - public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3, - LispObject obj4, LispObject obj5) - { - Debug.assertTrue(obj1 == this); - classPrecedenceList = list(obj1, obj2, obj3, obj4, obj5); - } - - public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3, - LispObject obj4, LispObject obj5, LispObject obj6) - { - Debug.assertTrue(obj1 == this); - classPrecedenceList = list(obj1, obj2, obj3, obj4, obj5, obj6); - } - - public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3, - LispObject obj4, LispObject obj5, LispObject obj6, - LispObject obj7) + public LispObject getDirectMethods() { - Debug.assertTrue(obj1 == this); - classPrecedenceList = list(obj1, obj2, obj3, obj4, obj5, obj6, obj7); + return directMethods; } - public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3, - LispObject obj4, LispObject obj5, LispObject obj6, - LispObject obj7, LispObject obj8) + public void setDirectMethods(LispObject methods) { - Debug.assertTrue(obj1 == this); - classPrecedenceList = - list(obj1, obj2, obj3, obj4, obj5, obj6, obj7, obj8); + directMethods = methods; } - public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3, - LispObject obj4, LispObject obj5, LispObject obj6, - LispObject obj7, LispObject obj8, LispObject obj9) + public LispObject getDocumentation() { - Debug.assertTrue(obj1 == this); - classPrecedenceList = - list(obj1, obj2, obj3, obj4, obj5, obj6, obj7, obj8, obj9); + return documentation; } - public String getName() + public void setDocumentation(LispObject doc) { - return symbol.getName(); + documentation = doc; } @Override @@ -315,7 +291,7 @@ public boolean subclassp(LispObject obj) { - LispObject cpl = classPrecedenceList; + LispObject cpl = getCPL(); while (cpl != NIL) { if (cpl.car() == obj) Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Sun Feb 14 16:29:58 2010 @@ -5316,7 +5316,7 @@ @Override public LispObject execute(LispObject arg) { - return checkClass(arg).symbol; + return checkClass(arg).getName(); } }; @@ -5331,7 +5331,7 @@ public LispObject execute(LispObject first, LispObject second) { - checkClass(first).symbol = checkSymbol(second); + checkClass(first).setName(checkSymbol(second)); return second; } }; @@ -5452,7 +5452,7 @@ public LispObject execute(LispObject first, LispObject second) { - checkClass(first).classPrecedenceList = second; + checkClass(first).setCPL(second); return second; } }; @@ -5468,7 +5468,7 @@ public LispObject execute(LispObject arg) { - return checkClass(arg).directMethods; + return checkClass(arg).getDirectMethods(); } }; @@ -5483,13 +5483,14 @@ public LispObject execute(LispObject first, LispObject second) { - checkClass(first).directMethods = second; + checkClass(first).setDirectMethods(second); return second; } }; // ### class-documentation - private static final Primitive CLASS_DOCUMENTATION = new pf_class_documentation(); + private static final Primitive CLASS_DOCUMENTATION + = new pf_class_documentation(); private static final class pf_class_documentation extends Primitive { pf_class_documentation() { super("class-documentation", PACKAGE_SYS, true); @@ -5499,12 +5500,13 @@ public LispObject execute(LispObject arg) { - return checkClass(arg).documentation; + return checkClass(arg).getDocumentation(); } }; // ### %set-class-documentation - private static final Primitive _SET_CLASS_DOCUMENTATION = new pf__set_class_documentation(); + private static final Primitive _SET_CLASS_DOCUMENTATION + = new pf__set_class_documentation(); private static final class pf__set_class_documentation extends Primitive { pf__set_class_documentation() { super("%set-class-documentation", PACKAGE_SYS, true); @@ -5514,7 +5516,7 @@ public LispObject execute(LispObject first, LispObject second) { - checkClass(first).documentation = second; + checkClass(first).setDocumentation(second); return second; } }; Modified: trunk/abcl/src/org/armedbear/lisp/SlotClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlotClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SlotClass.java Sun Feb 14 16:29:58 2010 @@ -42,23 +42,35 @@ private LispObject directDefaultInitargs = NIL; private LispObject defaultInitargs = NIL; - public SlotClass() + public SlotClass(Layout layout) { + super(layout); } public SlotClass(Symbol symbol, LispObject directSuperclasses) + + + { + this(null, symbol, directSuperclasses); + } + + public SlotClass(Layout layout, + Symbol symbol, LispObject directSuperclasses) { - super(symbol, directSuperclasses); + super(layout, symbol, directSuperclasses); } @Override public LispObject getParts() { LispObject result = super.getParts().nreverse(); - result = result.push(new Cons("DIRECT-SLOTS", directSlotDefinitions)); - result = result.push(new Cons("SLOTS", slotDefinitions)); - result = result.push(new Cons("DIRECT-DEFAULT-INITARGS", directDefaultInitargs)); - result = result.push(new Cons("DEFAULT-INITARGS", defaultInitargs)); + result = result.push(new Cons("DIRECT-SLOTS", + getDirectSlotDefinitions())); + result = result.push(new Cons("SLOTS", getSlotDefinitions())); + result = result.push(new Cons("DIRECT-DEFAULT-INITARGS", + getDirectDefaultInitargs())); + result = result.push(new Cons("DEFAULT-INITARGS", + getDefaultInitargs())); return result.nreverse(); } @@ -78,7 +90,7 @@ this.directSlotDefinitions = directSlotDefinitions; } - public final LispObject getSlotDefinitions() + public LispObject getSlotDefinitions() { return slotDefinitions; } @@ -98,6 +110,11 @@ this.directDefaultInitargs = directDefaultInitargs; } + public LispObject getDefaultInitargs() + { + return defaultInitargs; + } + public void setDefaultInitargs(LispObject defaultInitargs) { this.defaultInitargs = defaultInitargs; @@ -124,7 +141,8 @@ if (isFinalized()) return; - Debug.assertTrue(slotDefinitions == NIL); + LispObject defs = getSlotDefinitions(); + Debug.assertTrue(defs == NIL); LispObject cpl = getCPL(); Debug.assertTrue(cpl != null); Debug.assertTrue(cpl.listp()); @@ -133,20 +151,20 @@ LispObject car = cpl.car(); if (car instanceof StandardClass) { StandardClass cls = (StandardClass) car; - LispObject defs = cls.getDirectSlotDefinitions(); - Debug.assertTrue(defs != null); - Debug.assertTrue(defs.listp()); - while (defs != NIL) { - slotDefinitions = slotDefinitions.push(defs.car()); - defs = defs.cdr(); + LispObject directDefs = cls.getDirectSlotDefinitions(); + Debug.assertTrue(directDefs != null); + Debug.assertTrue(directDefs.listp()); + while (directDefs != NIL) { + defs = defs.push(directDefs.car()); + directDefs = directDefs.cdr(); } } cpl = cpl.cdr(); } - slotDefinitions = slotDefinitions.nreverse(); - LispObject[] instanceSlotNames = new LispObject[slotDefinitions.length()]; + setSlotDefinitions(defs.nreverse()); + LispObject[] instanceSlotNames = new LispObject[defs.length()]; int i = 0; - LispObject tail = slotDefinitions; + LispObject tail = getSlotDefinitions(); while (tail != NIL) { SlotDefinition slotDefinition = (SlotDefinition) tail.car(); slotDefinition.setLocation(i); @@ -167,7 +185,7 @@ { if (arg instanceof SlotClass) - return ((SlotClass)arg).directSlotDefinitions; + return ((SlotClass)arg).getDirectSlotDefinitions(); if (arg instanceof BuiltInClass) return NIL; return type_error(arg, Symbol.STANDARD_CLASS); @@ -183,7 +201,7 @@ { if (first instanceof SlotClass) { - ((SlotClass)first).directSlotDefinitions = second; + ((SlotClass)first).setDirectSlotDefinitions(second); return second; } else { @@ -201,7 +219,7 @@ { if (arg instanceof SlotClass) - return ((SlotClass)arg).slotDefinitions; + return ((SlotClass)arg).getSlotDefinitions(); if (arg instanceof BuiltInClass) return NIL; return type_error(arg, Symbol.STANDARD_CLASS); @@ -216,12 +234,12 @@ public LispObject execute(LispObject first, LispObject second) { - if (first instanceof SlotClass) { - ((SlotClass)first).slotDefinitions = second; - return second; + if (first instanceof SlotClass) { + ((SlotClass)first).setSlotDefinitions(second); + return second; } - else { - return type_error(first, Symbol.STANDARD_CLASS); + else { + return type_error(first, Symbol.STANDARD_CLASS); } } }; @@ -235,7 +253,7 @@ { if (arg instanceof SlotClass) - return ((SlotClass)arg).directDefaultInitargs; + return ((SlotClass)arg).getDirectDefaultInitargs(); if (arg instanceof BuiltInClass) return NIL; return type_error(arg, Symbol.STANDARD_CLASS); @@ -250,11 +268,11 @@ public LispObject execute(LispObject first, LispObject second) { - if (first instanceof SlotClass) { - ((SlotClass)first).directDefaultInitargs = second; - return second; - } - return type_error(first, Symbol.STANDARD_CLASS); + if (first instanceof SlotClass) { + ((SlotClass)first).setDirectDefaultInitargs(second); + return second; + } + return type_error(first, Symbol.STANDARD_CLASS); } }; @@ -267,7 +285,7 @@ { if (arg instanceof SlotClass) - return ((SlotClass)arg).defaultInitargs; + return ((SlotClass)arg).getDefaultInitargs(); if (arg instanceof BuiltInClass) return NIL; return type_error(arg, Symbol.STANDARD_CLASS); @@ -283,7 +301,7 @@ { if (first instanceof SlotClass) { - ((SlotClass)first).defaultInitargs = second; + ((SlotClass)first).setDefaultInitargs(second); return second; } return type_error(first, Symbol.STANDARD_CLASS); Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Sun Feb 14 16:29:58 2010 @@ -37,24 +37,224 @@ public class StandardClass extends SlotClass { + + private static Symbol symName = PACKAGE_MOP.intern("NAME"); + private static Symbol symLayout = PACKAGE_MOP.intern("LAYOUT"); + private static Symbol symDirectSuperclasses + = PACKAGE_MOP.intern("DIRECT-SUPERCLASSES"); + private static Symbol symDirectSubclasses + = PACKAGE_MOP.intern("DIRECT-SUBCLASSES"); + private static Symbol symClassPrecedenceList + = PACKAGE_MOP.intern("CLASS-PRECEDENCE-LIST"); + private static Symbol symDirectMethods + = PACKAGE_MOP.intern("DIRECT-METHODS"); + private static Symbol symDocumentation + = PACKAGE_MOP.intern("DOCUMENTATION"); + private static Symbol symDirectSlots + = PACKAGE_MOP.intern("DIRECT-SLOTS"); + private static Symbol symSlots + = PACKAGE_MOP.intern("SLOTS"); + private static Symbol symDirectDefaultInitargs + = PACKAGE_MOP.intern("DIRECT-DEFAULT-INITARGS"); + private static Symbol symDefaultInitargs + = PACKAGE_MOP.intern("DEFAULT-INITARGS"); + + static Layout layoutStandardClass = + new Layout(null, + list(symName, + symLayout, + symDirectSuperclasses, + symDirectSubclasses, + symClassPrecedenceList, + symDirectMethods, + symDocumentation, + symDirectSlots, + symSlots, + symDirectDefaultInitargs, + symDefaultInitargs), + NIL) + { + @Override + public LispClass getLispClass() + { + return STANDARD_CLASS; + } + }; + public StandardClass() { - setClassLayout(new Layout(this, NIL, NIL)); + super(layoutStandardClass); + setDirectSuperclasses(NIL); + setDirectSubclasses(NIL); + setCPL(NIL); + setDirectMethods(NIL); + setDocumentation(NIL); + setDirectSlotDefinitions(NIL); + setSlotDefinitions(NIL); + setDirectDefaultInitargs(NIL); + setDefaultInitargs(NIL); } public StandardClass(Symbol symbol, LispObject directSuperclasses) { - super(symbol, directSuperclasses); - setClassLayout(new Layout(this, NIL, NIL)); + super(layoutStandardClass, + symbol, directSuperclasses); + setDirectSubclasses(NIL); + setCPL(NIL); + setDirectMethods(NIL); + setDocumentation(NIL); + setDirectSlotDefinitions(NIL); + setSlotDefinitions(NIL); + setDirectDefaultInitargs(NIL); + setDefaultInitargs(NIL); + } + + @Override + public LispObject getName() + { + return getInstanceSlotValue(symName); + } + + @Override + public void setName(LispObject newName) + { + setInstanceSlotValue(symName, newName); + } + + @Override + public Layout getClassLayout() + { + LispObject layout = getInstanceSlotValue(symLayout); + return (layout == UNBOUND_VALUE) ? null : (Layout)layout; + } + + @Override + public void setClassLayout(Layout newLayout) + { + setInstanceSlotValue(symLayout, newLayout); + } + + @Override + public LispObject getDirectSuperclasses() + { + return getInstanceSlotValue(symDirectSuperclasses); + } + + @Override + public void setDirectSuperclasses(LispObject directSuperclasses) + { + setInstanceSlotValue(symDirectSuperclasses, directSuperclasses); + } + + @Override + public LispObject getDirectSubclasses() + { + return getInstanceSlotValue(symDirectSubclasses); + } + + @Override + public void setDirectSubclasses(LispObject directSubclasses) + { + setInstanceSlotValue(symDirectSubclasses, directSubclasses); + } + + @Override + public LispObject getCPL() + { + return getInstanceSlotValue(symClassPrecedenceList); + } + + @Override + public void setCPL(LispObject... cpl) + { + LispObject obj1 = cpl[0]; + if (obj1.listp() && cpl.length == 1) + setInstanceSlotValue(symClassPrecedenceList, obj1); + else + { + Debug.assertTrue(obj1 == this); + LispObject l = NIL; + for (int i = cpl.length; i-- > 0;) + l = new Cons(cpl[i], l); + setInstanceSlotValue(symClassPrecedenceList, l); + } + } + + @Override + public LispObject getDirectMethods() + { + return getInstanceSlotValue(symDirectMethods); + } + + @Override + public void setDirectMethods(LispObject methods) + { + setInstanceSlotValue(symDirectMethods, methods); } @Override - public LispObject typeOf() + public LispObject getDocumentation() { - return Symbol.STANDARD_CLASS; + return getInstanceSlotValue(symDocumentation); } @Override + public void setDocumentation(LispObject doc) + { + setInstanceSlotValue(symDocumentation, doc); + } + + @Override + public LispObject getDirectSlotDefinitions() + { + return getInstanceSlotValue(symDirectSlots); + } + + @Override + public void setDirectSlotDefinitions(LispObject directSlotDefinitions) + { + setInstanceSlotValue(symDirectSlots, directSlotDefinitions); + } + + @Override + public LispObject getSlotDefinitions() + { + return getInstanceSlotValue(symSlots); + } + + @Override + public void setSlotDefinitions(LispObject slotDefinitions) + { + setInstanceSlotValue(symSlots, slotDefinitions); + } + + @Override + public LispObject getDirectDefaultInitargs() + { + return getInstanceSlotValue(symDirectDefaultInitargs); + } + + @Override + public void setDirectDefaultInitargs(LispObject directDefaultInitargs) + { + setInstanceSlotValue(symDirectDefaultInitargs, directDefaultInitargs); + } + + @Override + public LispObject getDefaultInitargs() + { + return getInstanceSlotValue(symDefaultInitargs); + } + + @Override + public void setDefaultInitargs(LispObject defaultInitargs) + { + setInstanceSlotValue(symDefaultInitargs, defaultInitargs); + } + + + + @Override public LispObject classOf() { return STANDARD_CLASS; @@ -89,10 +289,10 @@ { StringBuilder sb = new StringBuilder(Symbol.STANDARD_CLASS.writeToString()); - if (symbol != null) + if (getName() != null) { sb.append(' '); - sb.append(symbol.writeToString()); + sb.append(getName().writeToString()); } return unreadableString(sb.toString()); } @@ -114,6 +314,16 @@ public static final StandardClass STANDARD_OBJECT = addStandardClass(Symbol.STANDARD_OBJECT, list(BuiltInClass.CLASS_T)); + public static final StandardClass SLOT_DEFINITION = + new SlotDefinitionClass(); + static + { + addClass(Symbol.SLOT_DEFINITION, SLOT_DEFINITION); + + STANDARD_CLASS.setClassLayout(layoutStandardClass); + STANDARD_CLASS.setDirectSlotDefinitions(STANDARD_CLASS.getClassLayout().generateSlotDefinitions()); + } + // BuiltInClass.FUNCTION is also null here (see previous comment). public static final StandardClass GENERIC_FUNCTION = addStandardClass(Symbol.GENERIC_FUNCTION, list(BuiltInClass.FUNCTION, @@ -259,13 +469,6 @@ addClass(Symbol.STANDARD_GENERIC_FUNCTION, STANDARD_GENERIC_FUNCTION); } - public static final StandardClass SLOT_DEFINITION = - new SlotDefinitionClass(); - static - { - addClass(Symbol.SLOT_DEFINITION, SLOT_DEFINITION); - } - public static void initializeStandardClasses() { // We need to call setDirectSuperclass() here for classes that have a 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 Sun Feb 14 16:29:58 2010 @@ -209,7 +209,7 @@ if (name != null) { StringBuilder sb = new StringBuilder(); - sb.append(getLispClass().getSymbol().writeToString()); + sb.append(getLispClass().getName().writeToString()); sb.append(' '); sb.append(name.writeToString()); return unreadableString(sb.toString()); Modified: trunk/abcl/src/org/armedbear/lisp/StandardMethod.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardMethod.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StandardMethod.java Sun Feb 14 16:29:58 2010 @@ -156,7 +156,7 @@ if (name != null) { StringBuilder sb = new StringBuilder(); - sb.append(getLispClass().getSymbol().writeToString()); + sb.append(getLispClass().getName().writeToString()); sb.append(' '); sb.append(name.writeToString()); LispObject specializers = @@ -169,7 +169,7 @@ { LispObject spec = specs.car(); if (spec instanceof LispClass) - names = names.push(((LispClass)spec).getSymbol()); + names = names.push(((LispClass)spec).getName()); else names = names.push(spec); specs = specs.cdr(); Modified: trunk/abcl/src/org/armedbear/lisp/StandardObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StandardObject.java Sun Feb 14 16:29:58 2010 @@ -45,9 +45,19 @@ layout = new Layout(StandardClass.STANDARD_OBJECT, NIL, NIL); } + + protected StandardObject(Layout layout, int length) + { + this.layout = layout; + slots = new LispObject[length]; + for (int i = slots.length; i-- > 0;) + slots[i] = UNBOUND_VALUE; + } + + protected StandardObject(LispClass cls, int length) { - layout = cls.getClassLayout(); + layout = cls == null ? null : cls.getClassLayout(); slots = new LispObject[length]; for (int i = slots.length; i-- > 0;) slots[i] = UNBOUND_VALUE; @@ -55,8 +65,8 @@ protected StandardObject(LispClass cls) { - layout = cls.getClassLayout(); - slots = new LispObject[layout.getLength()]; + layout = cls == null ? null : cls.getClassLayout(); + slots = new LispObject[layout == null ? 0 : layout.getLength()]; for (int i = slots.length; i-- > 0;) slots[i] = UNBOUND_VALUE; } @@ -90,7 +100,7 @@ public final LispClass getLispClass() { - return layout.lispClass; + return layout.getLispClass(); } @Override @@ -100,16 +110,16 @@ // conditions, TYPE-OF returns the proper name of the class returned by // CLASS-OF if it has a proper name, and otherwise returns the class // itself." - final LispClass c1 = layout.lispClass; + final LispClass c1 = layout.getLispClass(); // The proper name of a class is "a symbol that names the class whose // name is that symbol". - final Symbol symbol = c1.getSymbol(); - if (symbol != NIL) + final LispObject name = c1.getName(); + if (name != NIL && name != UNBOUND_VALUE) { // TYPE-OF.9 - final LispObject c2 = LispClass.findClass(symbol); + final LispObject c2 = LispClass.findClass(checkSymbol(name)); if (c2 == c1) - return symbol; + return name; } return c1; } @@ -117,7 +127,7 @@ @Override public LispObject classOf() { - return layout.lispClass; + return layout.getLispClass(); } @Override @@ -127,19 +137,19 @@ return T; if (type == StandardClass.STANDARD_OBJECT) return T; - LispClass cls = layout != null ? layout.lispClass : null; + LispClass cls = layout != null ? layout.getLispClass() : null; if (cls != null) { if (type == cls) return T; - if (type == cls.getSymbol()) + if (type == cls.getName()) return T; LispObject cpl = cls.getCPL(); while (cpl != NIL) { if (type == cpl.car()) return T; - if (type == ((LispClass)cpl.car()).getSymbol()) + if (type == ((LispClass)cpl.car()).getName()) return T; cpl = cpl.cdr(); } @@ -173,7 +183,7 @@ { Debug.assertTrue(layout.isInvalid()); Layout oldLayout = layout; - LispClass cls = oldLayout.lispClass; + LispClass cls = oldLayout.getLispClass(); Layout newLayout = cls.getClassLayout(); Debug.assertTrue(!newLayout.isInvalid()); StandardObject newInstance = new StandardObject(cls); @@ -340,7 +350,7 @@ @Override public LispObject execute(LispObject arg) { - return checkStandardObject(arg).layout.lispClass; + return checkStandardObject(arg).layout.getLispClass(); } }; Modified: trunk/abcl/src/org/armedbear/lisp/StructureClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StructureClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StructureClass.java Sun Feb 14 16:29:58 2010 @@ -79,7 +79,7 @@ public String writeToString() { StringBuffer sb = new StringBuffer("#'); return sb.toString(); } Modified: trunk/abcl/src/org/armedbear/lisp/StructureObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StructureObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StructureObject.java Sun Feb 14 16:29:58 2010 @@ -144,7 +144,7 @@ @Override public LispObject typeOf() { - return structureClass.getSymbol(); + return structureClass.getName(); } @Override @@ -175,7 +175,7 @@ { if (type instanceof StructureClass) return memq(type, structureClass.getCPL()) ? T : NIL; - if (type == structureClass.getSymbol()) + if (type == structureClass.getName()) return T; if (type == Symbol.STRUCTURE_OBJECT) return T; @@ -421,7 +421,7 @@ return stream.getString().getStringValue(); } if (_PRINT_STRUCTURE_.symbolValue(thread) == NIL) - return unreadableString(structureClass.getSymbol().writeToString()); + return unreadableString(structureClass.getName().writeToString()); int maxLevel = Integer.MAX_VALUE; LispObject printLevel = Symbol.PRINT_LEVEL.symbolValue(thread); if (printLevel instanceof Fixnum) @@ -432,7 +432,7 @@ if (currentLevel >= maxLevel && slots.length > 0) return "#"; StringBuilder sb = new StringBuilder("#S("); - sb.append(structureClass.getSymbol().writeToString()); + sb.append(structureClass.getName().writeToString()); if (currentLevel < maxLevel) { LispObject effectiveSlots = structureClass.getSlotDefinitions(); 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 Sun Feb 14 16:29:58 2010 @@ -1781,6 +1781,7 @@ ))) (fmakunbound 'class-name) +(fmakunbound '(setf class-name)) (defgeneric class-name (class)) @@ -1800,6 +1801,9 @@ (defmethod class-precedence-list ((class class)) (%class-precedence-list class)) + + +(fmakunbound 'documentation) (defgeneric documentation (x doc-type)) (defgeneric (setf documentation) (new-value x doc-type)) @@ -2389,4 +2393,5 @@ ;; FIXME (defgeneric function-keywords (method)) + (provide 'clos) Modified: trunk/abcl/src/org/armedbear/lisp/make_condition.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/make_condition.java (original) +++ trunk/abcl/src/org/armedbear/lisp/make_condition.java Sun Feb 14 16:29:58 2010 @@ -52,7 +52,7 @@ if (type instanceof Symbol) symbol = (Symbol) type; else if (type instanceof LispClass) - symbol = ((LispClass)type).getSymbol(); + symbol = checkSymbol(((LispClass)type).getName()); else { // This function only works on symbols and classes. return NIL; From ehuelsmann at common-lisp.net Sun Feb 14 21:30:24 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Feb 2010 16:30:24 -0500 Subject: [armedbear-cvs] r12482 - branches/metaclass Message-ID: Author: ehuelsmann Date: Sun Feb 14 16:30:23 2010 New Revision: 12482 Log: Delete branch for rebranching. Removed: branches/metaclass/ From ehuelsmann at common-lisp.net Sun Feb 14 21:31:35 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Feb 2010 16:31:35 -0500 Subject: [armedbear-cvs] r12483 - branches/metaclass Message-ID: Author: ehuelsmann Date: Sun Feb 14 16:31:34 2010 New Revision: 12483 Log: Recreate branch deleted in r12482 from trunk. Added: branches/metaclass/ - copied from r12482, /trunk/ From mevenson at common-lisp.net Wed Feb 17 14:14:46 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 17 Feb 2010 09:14:46 -0500 Subject: [armedbear-cvs] r12484 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Feb 17 09:14:43 2010 New Revision: 12484 Log: Fix bug in loading fasls with "." in NAME of pathname. Perform the same transformation in the load portion init FASL as COMPUTE-CLASSFILE-NAME did in creating the files.. 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 Wed Feb 17 09:14:43 2010 @@ -557,7 +557,8 @@ (%stream-terpri out) (dump-form `(dotimes (,count-sym ,*class-number*) (function-preload - (%format nil "~A-~D.cls" ,(pathname-name output-file) + (%format nil "~A-~D.cls" + ,(substitute #\_ #\. (pathname-name output-file)) (1+ ,count-sym)))) out) (%stream-terpri out)) From mevenson at common-lisp.net Wed Feb 17 14:15:36 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 17 Feb 2010 09:15:36 -0500 Subject: [armedbear-cvs] r12485 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Feb 17 09:15:36 2010 New Revision: 12485 Log: Allow pathnames for filenames starting with "." to have TYPE. 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 Wed Feb 17 09:15:36 2010 @@ -364,7 +364,7 @@ } directory = parseDirectory(d); } - if (s.startsWith(".")) { + if (s.startsWith(".") && s.indexOf(".", 1) == -1) { name = new SimpleString(s); return; } From mevenson at common-lisp.net Sat Feb 20 11:27:17 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 20 Feb 2010 06:27:17 -0500 Subject: [armedbear-cvs] r12486 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: mevenson Date: Sat Feb 20 06:27:07 2010 New Revision: 12486 Log: Fix a couple of bugs in PATHNAME; reindent primitives. Restablish (pathname-name #p"...") => "..." behavior which was broken with [svn r12485]. Fixes ABCL.TEST.LISP::LOTS-OF-DOTS.[12]. MERGE-PATHNAMES fixed for jar-file pathnames referencing a hierarchial jar entry. JAR-FILE.MERGE-PATHNAMES.5 now tests for this case. Stack-friendly primitives normalized (reluctantly) to the Hungarian-style notation ("pf_function") introduced by Ville. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/test/lisp/abcl/jar-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Sat Feb 20 06:27:07 2010 @@ -364,7 +364,10 @@ } directory = parseDirectory(d); } - if (s.startsWith(".") && s.indexOf(".", 1) == -1) { + if (s.startsWith(".") + // No TYPE can be parsed + && (s.indexOf(".", 1) == -1 + || s.substring(s.length() -1).equals("."))) { name = new SimpleString(s); return; } @@ -858,9 +861,9 @@ } } // ### %pathname-host - private static final Primitive _PATHNAME_HOST = new _pathname_host(); - private static class _pathname_host extends Primitive { - _pathname_host() { + private static final Primitive _PATHNAME_HOST = new pf_pathname_host(); + private static class pf_pathname_host extends Primitive { + pf_pathname_host() { super("%pathname-host", PACKAGE_SYS, false); } @Override @@ -870,9 +873,9 @@ } } // ### %pathname-device - private static final Primitive _PATHNAME_DEVICE = new _pathname_device(); - private static class _pathname_device extends Primitive { - _pathname_device() { + private static final Primitive _PATHNAME_DEVICE = new pf_pathname_device(); + private static class pf_pathname_device extends Primitive { + pf_pathname_device() { super("%pathname-device", PACKAGE_SYS, false); } @Override @@ -882,9 +885,9 @@ } } // ### %pathname-directory - private static final Primitive _PATHNAME_DIRECTORY = new _pathname_directory(); - private static class _pathname_directory extends Primitive { - _pathname_directory() { + private static final Primitive _PATHNAME_DIRECTORY = new pf_pathname_directory(); + private static class pf_pathname_directory extends Primitive { + pf_pathname_directory() { super("%pathname-directory", PACKAGE_SYS, false); } @Override @@ -894,9 +897,9 @@ } } // ### %pathname-name - private static final Primitive _PATHNAME_NAME = new _pathname_name(); - private static class _pathname_name extends Primitive { - _pathname_name() { + private static final Primitive _PATHNAME_NAME = new pf_pathname_name(); + private static class pf_pathname_name extends Primitive { + pf_pathname_name() { super ("%pathname-name", PACKAGE_SYS, false); } @Override @@ -906,9 +909,9 @@ } } // ### %pathname-type - private static final Primitive _PATHNAME_TYPE = new _pathname_type(); - private static class _pathname_type extends Primitive { - _pathname_type() { + private static final Primitive _PATHNAME_TYPE = new pf_pathname_type(); + private static class pf_pathname_type extends Primitive { + pf_pathname_type() { super("%pathname-type", PACKAGE_SYS, false); } @Override @@ -918,9 +921,9 @@ } } // ### pathname-version - private static final Primitive PATHNAME_VERSION = new pathname_version(); - private static class pathname_version extends Primitive { - pathname_version() { + private static final Primitive PATHNAME_VERSION = new pf_pathname_version(); + private static class pf_pathname_version extends Primitive { + pf_pathname_version() { super("pathname-version", "pathname"); } @Override @@ -930,9 +933,9 @@ } // ### namestring // namestring pathname => namestring - private static final Primitive NAMESTRING = new namestring(); - private static class namestring extends Primitive { - namestring() { + private static final Primitive NAMESTRING = new pf_namestring(); + private static class pf_namestring extends Primitive { + pf_namestring() { super("namestring", "pathname"); } @Override @@ -948,9 +951,9 @@ } // ### directory-namestring // directory-namestring pathname => namestring - private static final Primitive DIRECTORY_NAMESTRING = new directory_namestring(); - private static class directory_namestring extends Primitive { - directory_namestring() { + private static final Primitive DIRECTORY_NAMESTRING = new pf_directory_namestring(); + private static class pf_directory_namestring extends Primitive { + pf_directory_namestring() { super("directory-namestring", "pathname"); } @Override @@ -959,9 +962,9 @@ } } // ### pathname pathspec => pathname - private static final Primitive PATHNAME = new pathname(); - private static class pathname extends Primitive { - pathname() { + private static final Primitive PATHNAME = new pf_pathname(); + private static class pf_pathname extends Primitive { + pf_pathname() { super("pathname", "pathspec"); } @Override @@ -970,9 +973,9 @@ } } // ### %parse-namestring string host default-pathname => pathname, position - private static final Primitive _PARSE_NAMESTRING = new _parse_namestring(); - private static class _parse_namestring extends Primitive { - _parse_namestring() { + private static final Primitive _PARSE_NAMESTRING = new pf_parse_namestring(); + private static class pf_parse_namestring extends Primitive { + pf_parse_namestring() { super("%parse-namestring", PACKAGE_SYS, false, "namestring host default-pathname"); } @@ -1002,9 +1005,9 @@ } } // ### make-pathname - private static final Primitive MAKE_PATHNAME = new make_pathname(); - private static class make_pathname extends Primitive { - make_pathname() { + private static final Primitive MAKE_PATHNAME = new pf_make_pathname(); + private static class pf_make_pathname extends Primitive { + pf_make_pathname() { super("make-pathname", "&key host device directory name type version defaults case"); } @@ -1199,9 +1202,9 @@ return true; } // ### pathnamep - private static final Primitive PATHNAMEP = new pathnamep(); - private static class pathnamep extends Primitive { - pathnamep() { + private static final Primitive PATHNAMEP = new pf_pathnamep(); + private static class pf_pathnamep extends Primitive { + pf_pathnamep() { super("pathnamep", "object"); } @Override @@ -1210,9 +1213,9 @@ } } // ### logical-pathname-p - private static final Primitive LOGICAL_PATHNAME_P = new logical_pathname_p(); - private static class logical_pathname_p extends Primitive { - logical_pathname_p() { + private static final Primitive LOGICAL_PATHNAME_P = new pf_logical_pathname_p(); + private static class pf_logical_pathname_p extends Primitive { + pf_logical_pathname_p() { super("logical-pathname-p", PACKAGE_SYS, true, "object"); } @Override @@ -1221,9 +1224,9 @@ } } // ### user-homedir-pathname &optional host => pathname - private static final Primitive USER_HOMEDIR_PATHNAME = new user_homedir_pathname(); - private static class user_homedir_pathname extends Primitive { - user_homedir_pathname() { + private static final Primitive USER_HOMEDIR_PATHNAME = new pf_user_homedir_pathname(); + private static class pf_user_homedir_pathname extends Primitive { + pf_user_homedir_pathname() { super("user-homedir-pathname", "&optional host"); } @Override @@ -1244,9 +1247,9 @@ } } // ### list-directory directory - private static final Primitive LIST_DIRECTORY = new list_directory(); - private static class list_directory extends Primitive { - list_directory() { + private static final Primitive LIST_DIRECTORY = new pf_list_directory(); + private static class pf_list_directory extends Primitive { + pf_list_directory() { super("list-directory", PACKAGE_SYS, true, "directory"); } @Override @@ -1301,9 +1304,9 @@ } // ### PATHNAME-JAR-P - private static final Primitive PATHNAME_JAR_P = new pathname_jar_p(); - private static class pathname_jar_p extends Primitive { - pathname_jar_p() { + private static final Primitive PATHNAME_JAR_P = new pf_pathname_jar_p(); + private static class pf_pathname_jar_p extends Primitive { + pf_pathname_jar_p() { super("pathname-jar-p", PACKAGE_SYS, true, "pathname", "Predicate for whether PATHNAME references a JAR."); } @@ -1348,81 +1351,83 @@ return false; } // ### %wild-pathname-p - private static final Primitive _WILD_PATHNAME_P = - new Primitive("%wild-pathname-p", PACKAGE_SYS, true) { + private static final Primitive _WILD_PATHNAME_P = new pf_wild_pathname_p(); + static final class pf_wild_pathname_p extends Primitive { + pf_wild_pathname_p() { + super("%wild-pathname-p", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject first, LispObject second) { + Pathname pathname = coerceToPathname(first); + if (second == NIL) { + return pathname.isWild() ? T : NIL; + } + if (second == Keyword.DIRECTORY) { + if (pathname.directory instanceof Cons) { + if (memq(Keyword.WILD, pathname.directory)) { + return T; + } + if (memq(Keyword.WILD_INFERIORS, pathname.directory)) { + return T; + } + } + return NIL; + } + LispObject value; + if (second == Keyword.HOST) { + value = pathname.host; + } else if (second == Keyword.DEVICE) { + value = pathname.device; + } else if (second == Keyword.NAME) { + value = pathname.name; + } else if (second == Keyword.TYPE) { + value = pathname.type; + } else if (second == Keyword.VERSION) { + value = pathname.version; + } else { + return error(new ProgramError("Unrecognized keyword " + + second.writeToString() + ".")); + } + if (value == Keyword.WILD || value == Keyword.WILD_INFERIORS) { + return T; + } else { + return NIL; + } + } + } - @Override - public LispObject execute(LispObject first, LispObject second) { - Pathname pathname = coerceToPathname(first); - if (second == NIL) { - return pathname.isWild() ? T : NIL; - } - if (second == Keyword.DIRECTORY) { - if (pathname.directory instanceof Cons) { - if (memq(Keyword.WILD, pathname.directory)) { - return T; - } - if (memq(Keyword.WILD_INFERIORS, pathname.directory)) { - return T; - } - } - return NIL; - } - LispObject value; - if (second == Keyword.HOST) { - value = pathname.host; - } else if (second == Keyword.DEVICE) { - value = pathname.device; - } else if (second == Keyword.NAME) { - value = pathname.name; - } else if (second == Keyword.TYPE) { - value = pathname.type; - } else if (second == Keyword.VERSION) { - value = pathname.version; - } else { - return error(new ProgramError("Unrecognized keyword " - + second.writeToString() + ".")); - } - if (value == Keyword.WILD || value == Keyword.WILD_INFERIORS) { - return T; - } else { - return NIL; - } - } - }; - // ### merge-pathnames - private static final Primitive MERGE_PATHNAMES = - new Primitive("merge-pathnames", - "pathname &optional default-pathname default-version") { - - @Override - public LispObject execute(LispObject arg) { - Pathname pathname = coerceToPathname(arg); - Pathname defaultPathname = + // ### merge-pathnames pathname &optional default-pathname default-version" + private static final Primitive MERGE_PATHNAMES = new pf_merge_pathnames(); + static final class pf_merge_pathnames extends Primitive { + pf_merge_pathnames() { + super("merge-pathnames", "pathname &optional default-pathname default-version"); + } + @Override + public LispObject execute(LispObject arg) { + Pathname pathname = coerceToPathname(arg); + Pathname defaultPathname = coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue()); - LispObject defaultVersion = Keyword.NEWEST; - return mergePathnames(pathname, defaultPathname, defaultVersion); - } - - @Override - public LispObject execute(LispObject first, LispObject second) { - Pathname pathname = coerceToPathname(first); - Pathname defaultPathname = + LispObject defaultVersion = Keyword.NEWEST; + return mergePathnames(pathname, defaultPathname, defaultVersion); + } + @Override + public LispObject execute(LispObject first, LispObject second) { + Pathname pathname = coerceToPathname(first); + Pathname defaultPathname = coerceToPathname(second); - LispObject defaultVersion = Keyword.NEWEST; - return mergePathnames(pathname, defaultPathname, defaultVersion); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) { - Pathname pathname = coerceToPathname(first); - Pathname defaultPathname = + LispObject defaultVersion = Keyword.NEWEST; + return mergePathnames(pathname, defaultPathname, defaultVersion); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) { + Pathname pathname = coerceToPathname(first); + Pathname defaultPathname = coerceToPathname(second); - LispObject defaultVersion = third; - return mergePathnames(pathname, defaultPathname, defaultVersion); - } - }; + LispObject defaultVersion = third; + return mergePathnames(pathname, defaultPathname, defaultVersion); + } + } public static final Pathname mergePathnames(Pathname pathname, Pathname defaultPathname) { return mergePathnames(pathname, defaultPathname, Keyword.NEWEST); @@ -1474,6 +1479,7 @@ } ((Cons)result.device).car = o; } + result.directory = p.directory; } else { result.directory = mergeDirectories(p.directory, d.directory); } @@ -1849,9 +1855,9 @@ } // ### mkdir pathname - private static final Primitive MKDIR = new mkdir(); - private static class mkdir extends Primitive { - mkdir() { + private static final Primitive MKDIR = new pf_mkdir(); + private static class pf_mkdir extends Primitive { + pf_mkdir() { super("mkdir", PACKAGE_SYS, false, "pathname"); } @@ -1871,9 +1877,9 @@ } // ### rename-file filespec new-name => defaulted-new-name, old-truename, new-truename - private static final Primitive RENAME_FILE = new rename_file(); - private static class rename_file extends Primitive { - rename_file() { + private static final Primitive RENAME_FILE = new pf_rename_file(); + private static class pf_rename_file extends Primitive { + pf_rename_file() { super("rename-file", "filespec new-name"); } @Override @@ -1913,9 +1919,9 @@ } // ### file-namestring pathname => namestring - private static final Primitive FILE_NAMESTRING = new file_namestring(); - private static class file_namestring extends Primitive { - file_namestring() { + private static final Primitive FILE_NAMESTRING = new pf_file_namestring(); + private static class pf_file_namestring extends Primitive { + pf_file_namestring() { super("file-namestring", "pathname"); } @Override @@ -1940,9 +1946,9 @@ } // ### host-namestring pathname => namestring - private static final Primitive HOST_NAMESTRING = new host_namestring(); - private static class host_namestring extends Primitive { - host_namestring() { + private static final Primitive HOST_NAMESTRING = new pf_host_namestring(); + private static class pf_host_namestring extends Primitive { + pf_host_namestring() { super("host-namestring", "pathname"); } @Override Modified: trunk/abcl/test/lisp/abcl/jar-file.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/jar-file.lisp (original) +++ trunk/abcl/test/lisp/abcl/jar-file.lisp Sat Feb 20 06:27:07 2010 @@ -221,12 +221,15 @@ "jar:file:baz.jar!/foo" "/a/b/c") #p"jar:file:/a/b/baz.jar!/foo") +(deftest jar-file.merge-pathnames.5 + (merge-pathnames "jar:file:/a/b/c/foo.jar!/bar/baz.lisp") + #p"jar:file:/a/b/c/foo.jar!/bar/baz.lisp") + (deftest jar-file.truename.1 (signals-error (truename "jar:file:baz.jar!/foo") 'file-error) t) - (deftest jar-file.pathname.1 (let* ((p #p"jar:file:foo/baz.jar!/") (d (first (pathname-device p)))) From mevenson at common-lisp.net Sat Feb 20 12:04:16 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 20 Feb 2010 07:04:16 -0500 Subject: [armedbear-cvs] r12487 - in trunk/abcl: . contrib contrib/asdf-install Message-ID: Author: mevenson Date: Sat Feb 20 07:04:14 2010 New Revision: 12487 Log: Port of ASDF-INSTALL under 'contrib/asdf-install'. 'abcl.contrib' will package ASDF-INSTALL in dist/abcl-contrib.jar. We only have one contrib 'asdf-install'. It is not expected to work well under Windows at the moment. To use ASDF-INSTALL, use the following in your ~/.abclrc: (require 'asdf) (pushnew "jar:file:${dist.dir}/abcl-contrib.jar!/asdf-install/" asdf:*central-registry*) Then issuing CL-USER> (require 'asdf-install) will load ASDF-INSTALL. A file ~/.asdf-install can contain customizations to help ASDF-INSTALL find the programs 'tar' and 'gpg'. 'tar' is searched for in asdf-install:*shell-search-paths*. The location of 'gpg' can be customized by setting *gpg-command* to a string containing the file. This behavior should be rationalized in the future. ASDF-INSTALL tested under OSX. Added: trunk/abcl/contrib/ trunk/abcl/contrib/asdf-install/ trunk/abcl/contrib/asdf-install/COPYRIGHT trunk/abcl/contrib/asdf-install/Makefile trunk/abcl/contrib/asdf-install/README trunk/abcl/contrib/asdf-install/RELNOTES trunk/abcl/contrib/asdf-install/asdf-install.asd trunk/abcl/contrib/asdf-install/conditions.lisp trunk/abcl/contrib/asdf-install/dead-letter.lisp trunk/abcl/contrib/asdf-install/defpackage.lisp trunk/abcl/contrib/asdf-install/deprecated.lisp trunk/abcl/contrib/asdf-install/digitool.lisp trunk/abcl/contrib/asdf-install/installer.lisp trunk/abcl/contrib/asdf-install/lift-standard.config trunk/abcl/contrib/asdf-install/load-asdf-install.lisp trunk/abcl/contrib/asdf-install/loader.lisp trunk/abcl/contrib/asdf-install/port.lisp trunk/abcl/contrib/asdf-install/split-sequence.lisp trunk/abcl/contrib/asdf-install/variables.lisp Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Sat Feb 20 07:04:14 2010 @@ -346,6 +346,41 @@ + + + + + + + + + + + + + +Packaged contribs in ${dist.dir}/abcl-contrib.jar. + +To use ASDF-INSTALL, use the following in your ~/.abclrc: + + (require 'asdf) + (pushnew "jar:file:${dist.dir}/abcl-contrib.jar!/asdf-install/" asdf:*central-registry*) + +Then issuing + + CL-USER> (require 'asdf-install) + +will load ASDF-INSTALL. + + + Invoke ABCL with JPDA listener on port 6789 and is distributed with SBCL and +therefore in the public domain. The SBCL Common Lisp implementation +can be obtained from Sourceforge: . + +The initial port of ASDF-INSTALL to other Lisps was done by Dr. Edmund +Weitz and included the file port.lisp and some +changes to the files mentioned above. More code was provided by Marco +Baringer (OpenMCL port), James Anderson + (MCL port, including the file digitool.lisp), +Kiyoshi Mizumaru , Robert P. Goldman +, and Raymond Toy +(bugfixes). Marco Antoniotti added support for +MK:DEFSYSTEM which includes the files load-asdf-install.lisp, +loader.lisp, and finally split-sequence.lisp which has its own +copyright notice. ASDF-Install is currently maintained by Gary King + and is hosted on Common-Lisp.net. + +The complete code distributed with this archive (asdf-install.tar.gz) +is copyrighted by the above-mentioned authors and governed by the +following license. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials + provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS 'AS IS' AND ANY EXPRESSED OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + Added: trunk/abcl/contrib/asdf-install/Makefile ============================================================================== --- (empty file) +++ trunk/abcl/contrib/asdf-install/Makefile Sat Feb 20 07:04:14 2010 @@ -0,0 +1,13 @@ +SYSTEM=asdf-install +EXTRA_INSTALL_TARGETS=asdf-install-install + +include ../asdf-module.mk + +asdf-install-install: asdf-install + if test -f $(BUILD_ROOT)$(INSTALL_ROOT)/bin/sbcl-asdf-install ; then \ + mv $(BUILD_ROOT)$(INSTALL_ROOT)/bin/sbcl-asdf-install $(BUILD_ROOT)$(INSTALL_ROOT)/bin/sbcl-asdf-install.old ; \ + fi +# KLUDGE: mv rather than cp because keeping asdf-install in that +# directory interferes with REQUIRE, and this is done before the tar +# in ../asdf-module.mk. Better solutions welcome. + mv asdf-install $(BUILD_ROOT)$(INSTALL_ROOT)/bin/sbcl-asdf-install Added: trunk/abcl/contrib/asdf-install/README ============================================================================== --- (empty file) +++ trunk/abcl/contrib/asdf-install/README Sat Feb 20 07:04:14 2010 @@ -0,0 +1,121 @@ +Downloads and installs an ASDF or a MK:DEFSYSTEM system or anything +else that looks convincingly like one. It updates the +ASDF:*CENTRAL-REGISTRY* symlinks for all the toplevel .asd files it +contains, and it also MK:ADD-REGISTRY-LOCATION for the appropriate +directories for MK:DEFSYSTEM. + +Please read this file before use: in particular: this is an automatic +tool that downloads and compiles stuff it finds on the 'net. Please +look at the SECURITY section and be sure you understand the +implications + + += USAGE + +This can be used either from within a CL implementation: + +cl-prompt> (load "/path/to/load-asdf-install.lisp") +cl-prompt> (asdf-install:install 'xlunit) ; for example + +With SBCL you can also use the standalone command `sbcl-asdf-install' +from the shell: + +$ sbcl-asdf-install xlunit + + +Each argument may be - + + - The name of a cliki page. asdf-install visits that page and finds + the download location from the `:(package)' tag - usually rendered + as "Download ASDF package from ..." + + - A URL, which is downloaded directly + + - A local tar.gz file, which is installed + + += SECURITY CONCERNS: READ THIS CAREFULLY + +When you invoke asdf-install, you are asking your CL implementation to +download, compile, and install software from some random site on the +web. Given that it's indirected through a page on CLiki, any +malicious third party doesn't even need to hack the distribution +server to replace the package with something else: he can just edit +the link. + +For this reason, we encourage package providers to crypto-sign their +packages (see details at the URL in the PACKAGE CREATION section) and +users to check the signatures. asdf-install has three levels of +automatic signature checking: "on", "off" and "unknown sites", which +can be set using the configuration variables described in +CUSTOMIZATION below. The default is "unknown sites", which will +expect a GPG signature on all downloads except those from +presumed-good sites. The current default presumed-good sites are +CCLAN nodes, and two web sites run by SBCL maintainers: again, see +below for customization details + + += CUSTOMIZATION + +If the file $HOME/.asdf-install exists, it is loaded. This can be +used to override the default values of exported special variables. +Presently these are + +*PROXY* + defaults to $http_proxy environment variable +*CCLAN-MIRROR* + preferred/nearest CCLAN node. See the list at + http://ww.telent.net/cclan-choose-mirror +*ASDF-INSTALL-DIRS* + Set from ASDF_INSTALL_DIR environment variable. If you are running + SBCL, then *ASDF-INSTALL-DIRS* may be set form the environment variable + SBCL_HOME, which should already be correct for whatever SBCL is + running, if it's been installed correctly. This is done for + backward compatibility with SBCL installations. +*SBCL-HOME* + This is actually a symbol macro for *ASDF-INSTALL-DIRS* +*VERIFY-GPG-SIGNATURES* + Verify GPG signatures for the downloaded packages? + NIL - no, T - yes, :UNKNOWN-LOCATIONS - only for URLs which aren't in CCLAN + and don't begin with one of the prefixes in *SAFE-URL-PREFIXES* +*LOCATIONS* + Possible places in the filesystem to install packages into. See default + value for format +*SAFE-URL-PREFIXES* + List of locations for which GPG signature checking /won't/ be done when + *verify-gpg-signatures* is :unknown-locations + + += PACKAGE CREATION + +If you want to create your own packages that can be installed using this +loader, see the "Making your package downloadable..." section at + + + += HACKERS NOTE + +Listen very carefully: I will say this only as often as it appears to +be necessary to say it. asdf-install is not a good example of how to +write a URL parser, HTTP client, or anything else, really. +Well-written extensible and robust URL parsers, HTTP clients, FTP +clients, etc would definitely be nice things to have, but it would be +nicer to have them in CCLAN where anyone can use them - after having +downloaded them with asdf-install - than in SBCL contrib where they're +restricted to SBCL users and can only be updated once a month via SBCL +developers. This is a bootstrap tool, and as such, will tend to +resist changes that make it longer or dependent on more other +packages, unless they also add to its usefulness for bootstrapping. + + += TODO + +a) gpg signature checking would be better if it actually checked against +a list of "trusted to write Lisp" keys, instead of just "trusted to be +who they say they are" + +e) nice to have: resume half-done downloads instead of starting from scratch +every time. but right now we're dealing in fairly small packages, this is not +an immediate concern + + Added: trunk/abcl/contrib/asdf-install/RELNOTES ============================================================================== --- (empty file) +++ trunk/abcl/contrib/asdf-install/RELNOTES Sat Feb 20 07:04:14 2010 @@ -0,0 +1,5 @@ +12 Sept 2006 gwking at metabang.com + + * added :where parameter to install + * now uses more tempoary files + * changed selection of locations - 0 is always abort, can use symbols / strings Added: trunk/abcl/contrib/asdf-install/asdf-install.asd ============================================================================== --- (empty file) +++ trunk/abcl/contrib/asdf-install/asdf-install.asd Sat Feb 20 07:04:14 2010 @@ -0,0 +1,52 @@ +;;; -*- Lisp -*- + +;;; Portatble ASDF-Install is based on Dan Barlow's ASDF-Install +;; (see the file COPYRIGHT for details). It is currently maintained +;; by Gary King . + +(defpackage #:asdf-install-system + (:use #:cl #:asdf)) + +(in-package #:asdf-install-system) + +(defsystem asdf-install + #+:sbcl :depends-on + #+:sbcl (sb-bsd-sockets) + :version "0.6.10-ABCL.0" + :author "Dan Barlow , Edi Weitz and many others. See the file COPYRIGHT for more details." + :maintainer "Gary Warren King " + :components ((:file "defpackage") + (:file "split-sequence" :depends-on ("defpackage")) + + (:file "port" :depends-on ("defpackage" "split-sequence")) + #+:digitool + (:file "digitool" :depends-on ("port")) + + (:file "conditions" :depends-on ("defpackage" "variables")) + (:file "variables" :depends-on ("port")) + (:file "installer" + :depends-on ("port" "split-sequence" + #+:digitool "digitool" + "conditions" "variables")) + (:file "deprecated" :depends-on ("installer"))) + :in-order-to ((test-op (load-op test-asdf-install))) + :perform (test-op :after (op c) + (funcall + (intern (symbol-name '#:run-tests) :lift) + :config :generic))) + +(defmethod perform :after ((o load-op) (c (eql (find-system :asdf-install)))) + (let ((show-version (find-symbol + (symbol-name '#:show-version-information) + '#:asdf-install))) + (when (and show-version (fboundp show-version)) + (funcall show-version))) + (provide 'asdf-install)) + +(defmethod operation-done-p + ((o test-op) (c (eql (find-system :asdf-install)))) + nil) + +#+(or) +(defmethod perform ((o test-op) (c (eql (find-system :asdf-install)))) + t) Added: trunk/abcl/contrib/asdf-install/conditions.lisp ============================================================================== --- (empty file) +++ trunk/abcl/contrib/asdf-install/conditions.lisp Sat Feb 20 07:04:14 2010 @@ -0,0 +1,82 @@ +(in-package #:asdf-install) + +(define-condition download-error (error) + ((url :initarg :url :reader download-url) + (response :initarg :response :reader download-response)) + (:report (lambda (c s) + (format s "Server responded ~A for GET ~A" + (download-response c) (download-url c))))) + +(define-condition signature-error (error) + ((cause :initarg :cause :reader signature-error-cause)) + (:report (lambda (c s) + (format s "Cannot verify package signature: ~A" + (signature-error-cause c))))) + +(define-condition gpg-error (error) + ((message :initarg :message :reader gpg-error-message)) + (:report (lambda (c s) + (format s "GPG failed with error status:~%~S" + (gpg-error-message c))))) + +(define-condition gpg-shell-error (gpg-error) + () + (:report (lambda (c s) + (declare (ignore c)) + (format s "Call to GPG failed. Perhaps GPG is not installed or not ~ +in the path.")))) + +(define-condition no-signature (gpg-error) ()) + +(define-condition key-not-found (gpg-error) + ((key-id :initarg :key-id :reader key-id)) + (:report (lambda (c s) + (let* ((*print-circle* nil) + (key-id (key-id c)) + (key-id (if (and (consp key-id) + (> (length key-id) 1)) + (car key-id) key-id))) + (format s "~&No key found for key id 0x~A.~%" key-id) + (format s "~&Try some command like ~% gpg --recv-keys 0x~A" + (format nil "~a" key-id)))))) + +(define-condition key-not-trusted (gpg-error) + ((key-id :initarg :key-id :reader key-id) + (key-user-name :initarg :key-user-name :reader key-user-name)) + (:report (lambda (c s) + (format s "GPG warns that the key id 0x~A (~A) is not fully trusted" + (key-id c) (key-user-name c))))) + +(define-condition author-not-trusted (gpg-error) + ((key-id :initarg :key-id :reader key-id) + (key-user-name :initarg :key-user-name :reader key-user-name)) + (:report (lambda (c s) + (format s "~A (key id ~A) is not on your package supplier list" + (key-user-name c) (key-id c))))) + +(define-condition installation-abort (condition) + () + (:report (lambda (c s) + (declare (ignore c)) + (installer-msg s "Installation aborted.")))) + +(defun report-valid-preferred-locations (stream &optional attempted-location) + (when attempted-location + (installer-msg stream "~s is not a valid value for *preferred-location*" + attempted-location)) + (installer-msg stream "*preferred-location* may either be nil, a number between 1 and ~d \(the length of *locations*\) or the name of one of the *locations* \(~{~s~^, ~}\). If using a name, then it can be a symbol tested with #'eq or a string tested with #'string-equal." + (length *locations*) + (mapcar #'third *locations*))) + +(define-condition invalid-preferred-location-error (error) + ((preferred-location :initarg :preferred-location)) + (:report (lambda (c s) + (report-valid-preferred-locations + s (slot-value c 'preferred-location))))) + +(define-condition invalid-preferred-location-number-error + (invalid-preferred-location-error) ()) + +(define-condition invalid-preferred-location-name-error + (invalid-preferred-location-error) ()) + Added: trunk/abcl/contrib/asdf-install/dead-letter.lisp ============================================================================== --- (empty file) +++ trunk/abcl/contrib/asdf-install/dead-letter.lisp Sat Feb 20 07:04:14 2010 @@ -0,0 +1,34 @@ +;;;; dead letter + +#+Old +(defun load-system-definition (sysfile) + (declare (type pathname sysfile)) + #+asdf + (when (or (string-equal "asd" (pathname-type sysfile)) + (string-equal "asdf" (pathname-type sysfile))) + (installer-msg t "Loading system ~S via ASDF." (pathname-name sysfile)) + ;; just load the system definition + (load sysfile) + #+Ignore + (asdf:operate 'asdf:load-op (pathname-name sysfile))) + + #+mk-defsystem + (when (string-equal "system" (pathname-type sysfile)) + (installer-msg t "Loading system ~S via MK:DEFSYSTEM." (pathname-name sysfile)) + (mk:load-system (pathname-name sysfile)))) + +#+Old +;; from download-files-for-package +(with-open-file + #-(and allegro-version>= (not (version>= 8 0))) + (o file-name :direction :output + #+(or :clisp :digitool (and :lispworks :win32)) + :element-type + #+(or :clisp :digitool (and :lispworks :win32)) + '(unsigned-byte 8) + #+:sbcl #+:sbcl :external-format :latin1 + :if-exists :supersede) + ;; for Allegro versions < 8.0, the above #+sbcl #+sbcl + ;; will cause an error [2006/01/09:rpg] + #+(and allegro-version>= (not (version>= 8 0))) + (o file-name :direction :output :if-exists :supersede)) \ No newline at end of file Added: trunk/abcl/contrib/asdf-install/defpackage.lisp ============================================================================== --- (empty file) +++ trunk/abcl/contrib/asdf-install/defpackage.lisp Sat Feb 20 07:04:14 2010 @@ -0,0 +1,59 @@ +(cl:in-package :cl-user) + +(defpackage #:asdf-install + (:use #:common-lisp) + + #+asdf + (:import-from #:asdf #:*defined-systems*) + (:export + + ;; Customizable variables. + #:*shell-path* + #:*proxy* + #:*cclan-mirror* + #:asdf-install-dirs + #:private-asdf-install-dirs + #:*tar-extractors* + + #:*shell-search-paths* + #:*verify-gpg-signatures* + #:*locations* + #:*safe-url-prefixes* + #:*preferred-location* + #:*temporary-directory* + + ;; External entry points. + #:add-locations + #:add-registry-location + #:uninstall + #:install + #:asdf-install-version + + #+(and asdf (or :win32 :mswindows)) + #:sysdef-source-dir-search + + ;; proxy authentication + #:*proxy-user* + #:*proxy-passwd* + + ;; conditions + #:download-error + #:signature-error + #:gpg-error + #:gpg-shell-error + #:key-not-found + #:key-not-trusted + #:author-not-trusted + #:installation-abort + + ;; restarts + #:install-anyways + ) + + #+(or :win32 :mswindows) + (:export + #:*cygwin-bin-directory* + #:*cygwin-bash-command*)) + +(defpackage #:asdf-install-customize + (:use #:common-lisp #:asdf-install)) Added: trunk/abcl/contrib/asdf-install/deprecated.lisp ============================================================================== --- (empty file) +++ trunk/abcl/contrib/asdf-install/deprecated.lisp Sat Feb 20 07:04:14 2010 @@ -0,0 +1,216 @@ +(in-package asdf-install) + +#+(and ignore sbcl) ; Deprecated. +(define-symbol-macro *sbcl-home* *asdf-install-dirs*) + +#+(and ignore sbcl) ; Deprecated. +(define-symbol-macro *dot-sbcl* *private-asdf-install-dirs*) + +#+(or) +;; uncalled +(defun read-until-eof (stream) + (with-output-to-string (o) + (copy-stream stream o))) + + +#+(or) +(defun verify-gpg-signature/string (string file-name) + (block verify + (loop + (restart-case + (let ((gpg-stream (make-stream-from-gpg-command string file-name)) + tags) + (unwind-protect + (loop for l = (read-line gpg-stream nil nil) + while l + do (print l) + when (> (mismatch l "[GNUPG:]") 6) + do (destructuring-bind (_ tag &rest data) + (split-sequence-if (lambda (x) + (find x '(#\Space #\Tab))) + l) + (declare (ignore _)) + (pushnew (cons (intern (string-upcase tag) :keyword) + data) tags))) + (ignore-errors + (close gpg-stream))) + ;; test that command returned something + (unless tags + (error 'gpg-shell-error)) + ;; test for obvious key/sig problems + (let ((errsig (header-value :errsig tags))) + (and errsig (error 'key-not-found :key-id errsig))) + (let ((badsig (header-value :badsig tags))) + (and badsig (error 'key-not-found :key-id badsig))) + (let* ((good (header-value :goodsig tags)) + (id (first good)) + (name (format nil "~{~A~^ ~}" (rest good)))) + ;; good signature, but perhaps not trusted + (restart-case + (let ((trusted? (or (header-pair :trust_ultimate tags) + (header-pair :trust_fully tags))) + (in-list? (assoc id *trusted-uids* :test #'equal))) + (cond ((or trusted? in-list?) + ;; ok + ) + ((not trusted?) + (error 'key-not-trusted :key-user-name name :key-id id)) + ((not in-list?) + (error 'author-not-trusted + :key-user-name name :key-id id)) + (t + (error "Boolean logic gone bad. Run for the hills")))) + (add-key (&rest rest) + :report "Add to package supplier list" + (declare (ignore rest)) + (pushnew (list id name) *trusted-uids*)))) + (return-from verify t)) + #+Ignore + (install-anyways (&rest rest) + :report "Don't check GPG signature for this package" + (declare (ignore rest)) + (return-from verify t)) + (retry-gpg-check (&rest args) + :report "Retry GPG check \(e.g., after downloading the key\)" + (declare (ignore args)) + nil))))) + +#+(or) +(defun verify-gpg-signature/url (url file-name) + (block verify + (loop + (restart-case + (when (verify-gpg-signatures-p url) + (let ((sig-url (concatenate 'string url ".asc"))) + (destructuring-bind (response headers stream) + (url-connection sig-url) + (unwind-protect + (flet (#-:digitool + (read-signature (data stream) + (read-sequence data stream)) + #+:digitool + (read-signature (data stream) + (multiple-value-bind (reader arg) + (ccl:stream-reader stream) + (let ((byte 0)) + (dotimes (i (length data)) + (unless (setf byte (funcall reader arg)) + (error 'download-error :url sig-url + :response 200)) + (setf (char data i) (code-char byte))))))) + (if (= response 200) + (let ((data (make-string (parse-integer + (header-value :content-length headers) + :junk-allowed t)))) + (read-signature data stream) + (verify-gpg-signature/string data file-name)) + (error 'download-error :url sig-url + :response response))) + (close stream) + (return-from verify t))))) + (install-anyways (&rest rest) + :report "Don't check GPG signature for this package" + (declare (ignore rest)) + (return-from verify t)) + (retry-gpg-check (&rest args) + :report "Retry GPG check \(e.g., after fixing the network connection\)" + (declare (ignore args)) + nil))))) + + +#+(or :sbcl :cmu :scl) +(defun make-stream-from-gpg-command (string file-name) + (#+:sbcl sb-ext:process-output + #+(or :cmu :scl) ext:process-output + (#+:sbcl sb-ext:run-program + #+(or :cmu :scl) ext:run-program + "gpg" + (list + "--status-fd" "1" "--verify" "-" + (namestring file-name)) + :output :stream + :error nil + #+sbcl :search #+sbcl t + :input (make-string-input-stream string) + :wait t))) + +#+(and :lispworks (not :win32)) +(defun make-stream-from-gpg-command (string file-name) + ;; kludge - we can't separate the in and out streams + (let ((stream (sys:open-pipe (format nil "echo '~A' | gpg --status-fd 1 --verify - ~A" + string + (namestring file-name))))) + stream)) + + +#+(and :lispworks :win32) +(defun make-stream-from-gpg-command (string file-name) + (sys:open-pipe (format nil "gpg --status-fd 1 --verify \"~A\" \"~A\"" + (make-temp-sig file-name string) + (namestring file-name)))) + +#+(and :clisp (not (or :win32 :cygwin))) +(defun make-stream-from-gpg-command (string file-name) + (let ((stream + (ext:run-shell-command (format nil "echo '~A' | gpg --status-fd 1 --verify - ~A" + string + (namestring file-name)) + :output :stream + :wait nil))) + stream)) + +#+(and :clisp (or :win32 :cygwin)) +(defun make-stream-from-gpg-command (string file-name) + (ext:run-shell-command (format nil "gpg --status-fd 1 --verify \"~A\" \"~A\"" + (make-temp-sig file-name string) + (namestring file-name)) + :output :stream + :wait nil)) + +#+:allegro +(defun make-stream-from-gpg-command (string file-name) + (multiple-value-bind (in-stream out-stream) + (excl:run-shell-command + #-:mswindows + (concatenate 'vector + #("gpg" "gpg" "--status-fd" "1" "--verify" "-") + (make-sequence 'vector 1 + :initial-element (namestring file-name))) + #+:mswindows + (format nil "gpg --status-fd 1 --verify - \"~A\"" (namestring file-name)) + :input :stream + :output :stream + :separate-streams t + :wait nil) + (write-string string in-stream) + (finish-output in-stream) + (close in-stream) + out-stream)) + +#+:openmcl +(defun make-stream-from-gpg-command (string file-name) + (let ((proc (ccl:run-program "gpg" (list "--status-fd" "1" "--verify" "-" (namestring file-name)) + :input :stream + :output :stream + :wait nil))) + (write-string string (ccl:external-process-input-stream proc)) + (close (ccl:external-process-input-stream proc)) + (ccl:external-process-output-stream proc))) + +#+:digitool +(defun make-stream-from-gpg-command (string file-name) + (make-instance 'popen-input-stream + :command (format nil "echo '~A' | gpg --status-fd 1 --verify - '~A'" + string + (system-namestring file-name)))) + +#+(or) +(defun make-temp-sig (file-name content) + (let ((name (format nil "~A.asc" (namestring (truename file-name))))) + (with-open-file (out name + :direction :output + :if-exists :supersede) + (write-string content out)) + (pushnew name *temporary-files*) + name)) + Added: trunk/abcl/contrib/asdf-install/digitool.lisp ============================================================================== --- (empty file) +++ trunk/abcl/contrib/asdf-install/digitool.lisp Sat Feb 20 07:04:14 2010 @@ -0,0 +1,230 @@ +;;; -*- package: asdf-install; -*- +;;; +;;; Digitool-specific bootstrapping +;;; +;;; 2004-01-18 james.anderson at setf.de additions for MCL +;;; 2008-01-22 added exit-code checks to call-system + +(in-package #:asdf-install) + +#+:digitool +(let ((getenv-fn 0) + (setenv-fn 0) + (unsetenv-fn 0) + (popen-fn 0) + (pclose-fn 0) + (fread-fn 0) + (feof-fn 0)) + (ccl::with-cfstrs ((framework "System.framework")) + (let ((err 0) + (baseURL nil) + (bundleURL nil) + (bundle nil)) + (ccl::rlet ((folder :fsref)) + ;; Find the folder holding the bundle + (setf err (ccl::require-trap traps::_FSFindFolder + (ccl::require-trap-constant traps::$kOnAppropriateDisk) + (ccl::require-trap-constant traps::$kFrameworksFolderType) + t folder)) + ;; if everything's cool, make a URL for it + (when (zerop err) + (setf baseURL (ccl::require-trap traps::_CFURLCreateFromFSRef (ccl::%null-ptr) folder))) + (if (ccl::%null-ptr-p baseURL) + (setf err (ccl::require-trap-constant traps::$coreFoundationUnknownErr)))) + ;; if everything's cool, make a URL for the bundle + (when (zerop err) + (setf bundleURL (ccl::require-trap traps::_CFURLCreateCopyAppendingPathComponent (ccl::%null-ptr) baseURL framework nil)) + (if (ccl::%null-ptr-p bundleURL) + (setf err (ccl::require-trap-constant traps::$coreFoundationUnknownErr)))) + ;; if everything's cool, create it + (when (zerop err) + (setf bundle (ccl::require-trap traps::_CFBundleCreate (ccl::%null-ptr) bundleURL)) + (if (ccl::%null-ptr-p bundle) + (setf err (ccl::require-trap-constant traps::$coreFoundationUnknownErr)))) + ;; if everything's cool, load it + (when (zerop err) + (if (not (ccl::require-trap traps::_CFBundleLoadExecutable bundle)) + (setf err (ccl::require-trap-constant traps::$coreFoundationUnknownErr)))) + ;; if there's an error, but we've got a pointer, free it and clear result + (when (and (not (zerop err)) (not (ccl::%null-ptr-p bundle))) + (ccl::require-trap traps::_CFRelease bundle) + (setf bundle nil)) + ;; free the URLs if here non-null + (when (not (ccl::%null-ptr-p bundleURL)) + (ccl::require-trap traps::_CFRelease bundleURL)) + (when (not (ccl::%null-ptr-p baseURL)) + (ccl::require-trap traps::_CFRelease baseURL)) + (cond (bundle + ;; extract the necessary function id's + (flet ((get-addr (name) + (ccl::with-cfstrs ((c-name name)) + (let* ((addr (ccl::require-trap traps::_CFBundleGetFunctionPointerForName bundle c-name))) + (when (ccl::%null-ptr-p addr) + (error "Couldn't resolve address of foreign function ~s" name)) + (ccl::rlet ((buf :long)) + (setf (ccl::%get-ptr buf) addr) + (ash (ccl::%get-signed-long buf) -2)))))) + (setf getenv-fn (get-addr "getenv")) + (setf setenv-fn (get-addr "setenv")) + (setf unsetenv-fn (get-addr "unsetenv")) + (setf popen-fn (get-addr "popen")) + (setf pclose-fn (get-addr "pclose")) + (setf fread-fn (get-addr "fread")) + (setf feof-fn (get-addr "feof"))) + (ccl::require-trap traps::_CFRelease bundle) + (setf bundle nil)) + (t + (error "can't resolve core framework entry points."))))) + + (defun ccl::getenv (variable-name) + (ccl::with-cstrs ((c-variable-name variable-name)) + (let* ((env-ptr (ccl::%null-ptr))) + (declare (dynamic-extent env-ptr)) + (ccl::%setf-macptr env-ptr (ccl::ppc-ff-call getenv-fn + :address c-variable-name + :address)) + (unless (ccl::%null-ptr-p env-ptr) + (ccl::%get-cstring env-ptr))))) + + (defun ccl::setenv (variable-name variable-value) + (ccl::with-cstrs ((c-variable-name variable-name) + (c-variable-value variable-value)) + (ccl::ppc-ff-call setenv-fn + :address c-variable-name + :address c-variable-value + :signed-fullword 1 + :signed-fullword))) + + (defun ccl::unsetenv (variable-name) + (ccl::with-cstrs ((c-variable-name variable-name)) + (ccl::ppc-ff-call unsetenv-fn + :address c-variable-name + :void))) + + (labels ((fread (fp buffer length) + (ccl::ppc-ff-call fread-fn + :address buffer + :unsigned-fullword 1 + :unsigned-fullword length + :address fp + :signed-fullword)) + (feof-p (fp) + (not (zerop (ccl::ppc-ff-call feof-fn + :address fp + :signed-fullword)))) + (popen (command) + (ccl::with-cstrs ((read "r") + (cmd command)) + (ccl::ppc-ff-call popen-fn + :address cmd + :address read + :address))) + (pclose (fp) + (ccl::ppc-ff-call pclose-fn + :address fp + :signed-fullword)) + + (fread-decoded (fp io-buffer io-buffer-length string-buffer script) + (cond ((feof-p fp) + (values nil string-buffer)) + (t + (let ((io-count (fread fp io-buffer io-buffer-length))) + (cond ((and io-count (plusp io-count)) + (if script + (multiple-value-bind (chars fatp) (ccl::pointer-char-length io-buffer io-count script) + (cond ((not fatp) + (ccl::%copy-ptr-to-ivector io-buffer 0 string-buffer 0 io-count)) + (t + (unless (>= (length string-buffer) chars) + (setf string-buffer (make-string chars :element-type 'base-character))) + (ccl::pointer-to-string-in-script io-buffer string-buffer io-count script) + (setf io-count chars)))) + (ccl::%copy-ptr-to-ivector io-buffer 0 string-buffer 0 io-count)) + (values io-count string-buffer)) + (t + (values 0 string-buffer)))))))) + + (defun ccl::call-system (command) + (let* ((script (ccl::default-script nil)) + (table (ccl::get-char-byte-table script)) + (result (make-array 128 :element-type 'character :adjustable t :fill-pointer 0)) + (string-buffer (unless table (make-string 512 :element-type 'base-character))) + (io-count 0) + (fp (popen command)) + (exit-code 0)) + (unless (ccl::%null-ptr-p fp) + (unwind-protect + (ccl::%stack-block ((io-buffer 512)) + (loop (multiple-value-setq (io-count string-buffer) + (fread-decoded fp io-buffer 512 string-buffer (when table script))) + (unless io-count (return)) + (let ((char #\null)) + (dotimes (i io-count) + (case (setf char (schar string-buffer i)) + ((#\return #\linefeed) (setf char #\newline))) + (vector-push-extend char result))))) + (setf exit-code (pclose fp)) + (setf fp nil)) + (if (zerop exit-code) + (values result 0) + (values nil exit-code result))))) + + ;; need a function to avoid both the reader macro and the compiler + (setf (symbol-function '%new-ptr) #'ccl::%new-ptr) + + (defclass popen-input-stream (ccl::input-stream) + ((io-buffer :initform nil) + (fp :initform nil ) + (string-buffer :initform nil) + (length :initform 0) + (index :initform 0) + (script :initarg :script :initform (ccl::default-script nil))) + (:default-initargs :direction :input)) + + (defmethod initialize-instance :after ((instance popen-input-stream) &key command) + (with-slots (io-buffer string-buffer fp script) instance + (setf fp (popen command) + io-buffer (%new-ptr 512 nil) + string-buffer (make-string 512 :element-type 'base-character)) + (when script (unless (ccl::get-char-byte-table script) (setf script nil))))) + + (defmethod ccl::stream-close ((stream popen-input-stream)) + (declare (ignore abort)) + (with-slots (io-buffer string-buffer fp ccl::direction) stream + (when (and fp (not (ccl::%null-ptr-p fp))) + (pclose fp) + (setf fp nil) + (setf ccl::direction :closed) + (ccl::disposeptr io-buffer) + (setf io-buffer nil)))) + + (defmethod stream-element-type ((stream popen-input-stream)) + 'character) + + (defmethod ccl::stream-tyi ((stream popen-input-stream)) + ;; despite the decoding provisions, unix input comes with linefeeds + ;; and i don't know what decoding one would need. + (with-slots (io-buffer fp string-buffer length index script) stream + (when fp + (when (>= index length) + (multiple-value-setq (length string-buffer) + (fread-decoded fp io-buffer 512 string-buffer script)) + (unless (and length (plusp length)) + (setf length -1) + (return-from ccl::stream-tyi nil)) + (setf index 0)) + (let ((char (schar string-buffer index))) + (incf index) + (case char + ((#\return #\linefeed) #\newline) + (t char)))))) + + (defmethod ccl::stream-untyi ((stream popen-input-stream) char) + (with-slots (string-buffer length index) stream + (unless (and (plusp index) (eql char (schar (decf index) string-buffer))) + (error "invalid tyi character: ~s." char)) + char)) + + (defmethod ccl::stream-eofp ((stream popen-input-stream)) + (with-slots (length) stream + (minusp length))))) Added: trunk/abcl/contrib/asdf-install/installer.lisp ============================================================================== --- (empty file) +++ trunk/abcl/contrib/asdf-install/installer.lisp Sat Feb 20 07:04:14 2010 @@ -0,0 +1,577 @@ +(in-package #:asdf-install) + +(pushnew :asdf-install *features*) + +(defun installer-msg (stream format-control &rest format-arguments) + (apply #'format stream "~&;;; ASDF-INSTALL: ~@?~%" + format-control format-arguments)) + +(defun verify-gpg-signatures-p (url) + (labels ((prefixp (prefix string) + (let ((m (mismatch prefix string))) + (or (not m) (>= m (length prefix)))))) + (case *verify-gpg-signatures* + ((nil) nil) + ((:unknown-locations) + (notany + (lambda (x) (prefixp x url)) + *safe-url-prefixes*)) + (t t)))) + +(defun same-central-registry-entry-p (a b) + (flet ((ensure-string (x) + (typecase x + (string x) + (pathname (namestring (translate-logical-pathname x))) + (t nil)))) + (and (setf a (ensure-string a)) + (setf b (ensure-string b)) + a b (string-equal a b)))) + +(defun add-registry-location (location) + (let ((location-directory (pathname-sans-name+type location))) + #+asdf + (pushnew location-directory + asdf:*central-registry* + :test #'same-central-registry-entry-p) + + #+mk-defsystem + (mk:add-registry-location location-directory))) + +;;; Fixing the handling of *LOCATIONS* + +(defun add-locations (loc-name site system-site) + (declare (type string loc-name) + (type pathname site system-site)) + #+asdf + (progn + (pushnew site asdf:*central-registry* :test #'equal) + (pushnew system-site asdf:*central-registry* :test #'equal)) + + #+mk-defsystem + (progn + (mk:add-registry-location site) + (mk:add-registry-location system-site)) + (setf *locations* + (append *locations* (list (list site system-site loc-name))))) + +;;;--------------------------------------------------------------------------- +;;; URL handling. + +(defun url-host (url) + (assert (string-equal url "http://" :end1 7)) + (let* ((port-start (position #\: url :start 7)) + (host-end (min (or (position #\/ url :start 7) (length url)) + (or port-start (length url))))) + (subseq url 7 host-end))) + +(defun url-port (url) + (assert (string-equal url "http://" :end1 7)) + (let ((port-start (position #\: url :start 7))) + (if port-start + (parse-integer url :start (1+ port-start) :junk-allowed t) 80))) + +; This is from Juri Pakaste's base64.lisp +(defparameter *encode-table* + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=") + +(defun base64-encode (string) + (let ((result (make-array + (list (* 4 (truncate (/ (+ 2 (length string)) 3)))) + :element-type 'base-char))) + (do ((sidx 0 (+ sidx 3)) + (didx 0 (+ didx 4)) + (chars 2 2) + (value nil nil)) + ((>= sidx (length string)) t) + (setf value (ash (logand #xFF (char-code (char string sidx))) 8)) + (dotimes (n 2) + (when (< (+ sidx n 1) (length string)) + (setf value + (logior value + (logand #xFF (char-code (char string (+ sidx n 1)))))) + (incf chars)) + (when (= n 0) + (setf value (ash value 8)))) + (setf (elt result (+ didx 3)) + (elt *encode-table* (if (> chars 3) (logand value #x3F) 64))) + (setf value (ash value -6)) + (setf (elt result (+ didx 2)) + (elt *encode-table* (if (> chars 2) (logand value #x3F) 64))) + (setf value (ash value -6)) + (setf (elt result (+ didx 1)) + (elt *encode-table* (logand value #x3F))) + (setf value (ash value -6)) + (setf (elt result didx) + (elt *encode-table* (logand value #x3F)))) + result)) + +(defun request-uri (url) + (assert (string-equal url "http://" :end1 7)) + (if *proxy* + url + (let ((path-start (position #\/ url :start 7))) + (assert (and path-start) nil "url does not specify a file.") + (subseq url path-start)))) + +(defun url-connection (url) + (let ((stream (make-stream-from-url (or *proxy* url))) + (host (url-host url))) + (format stream "GET ~A HTTP/1.0~C~CHost: ~A~C~CCookie: CCLAN-SITE=~A~C~C" + (request-uri url) #\Return #\Linefeed + host #\Return #\Linefeed + *cclan-mirror* #\Return #\Linefeed) + (when (and *proxy-passwd* *proxy-user*) + (format stream "Proxy-Authorization: Basic ~A~C~C" + (base64-encode (format nil "~A:~A" *proxy-user* *proxy-passwd*)) + #\Return #\Linefeed)) + (format stream "~C~C" #\Return #\Linefeed) + (force-output stream) + (list + (let* ((l (read-header-line stream)) + (space (position #\Space l))) + (parse-integer l :start (1+ space) :junk-allowed t)) + (loop for line = (read-header-line stream) + until (or (null line) + (zerop (length line)) + (eql (elt line 0) (code-char 13))) + collect + (let ((colon (position #\: line))) + (cons (intern (string-upcase (subseq line 0 colon)) :keyword) + (string-trim (list #\Space (code-char 13)) + (subseq line (1+ colon)))))) + stream))) + +(defun download-link-for-package (package-name-or-url) + (if (= (mismatch package-name-or-url "http://") 7) + package-name-or-url + (format nil "http://www.cliki.net/~A?download" + package-name-or-url))) + +(defun download-link-for-signature (url) + (concatenate 'string url ".asc")) + +(defun download-files-for-package (package-name-or-url) + (multiple-value-bind (package-url package-file) + (download-url-to-temporary-file + (download-link-for-package package-name-or-url)) + (if (verify-gpg-signatures-p package-name-or-url) + (multiple-value-bind (signature-url signature-file) + (download-url-to-temporary-file + (download-link-for-signature package-url)) + (declare (ignore signature-url)) + (values package-file signature-file)) + (values package-file nil)))) + +(defun verify-gpg-signature (file-name signature-name) + (block verify + (loop + (restart-case + (let ((tags (gpg-results file-name signature-name))) + ;; test that command returned something + (unless tags + (error 'gpg-shell-error)) + ;; test for obvious key/sig problems + (let ((errsig (header-value :errsig tags))) + (and errsig (error 'key-not-found :key-id errsig))) + (let ((badsig (header-value :badsig tags))) + (and badsig (error 'key-not-found :key-id badsig))) + (let* ((good (header-value :goodsig tags)) + (id (first good)) + (name (format nil "~{~A~^ ~}" (rest good)))) + ;; good signature, but perhaps not trusted + (restart-case + (let ((trusted? (or (header-pair :trust_ultimate tags) + (header-pair :trust_fully tags))) + (in-list? (assoc id *trusted-uids* :test #'equal))) + (cond ((or trusted? in-list?) + ;; ok + ) + ((not trusted?) + (error 'key-not-trusted + :key-user-name name :key-id id)) + ((not in-list?) + (error 'author-not-trusted + :key-user-name name :key-id id)))) + (add-key (&rest rest) + :report "Add to package supplier list" + (declare (ignore rest)) + (pushnew (list id name) *trusted-uids*)))) + (return-from verify t)) + (install-anyways + (&rest rest) + :report "Don't check GPG signature for this package" + (declare (ignore rest)) + (return-from verify t)) + (retry-gpg-check + (&rest args) + :report "Retry GPG check \(e.g., after downloading the key\)" + (declare (ignore args)) + nil))))) + +(defun header-value (name headers) + "Searchers headers for name _without_ case sensitivity. Headers should be an alist mapping symbols to values; name a symbol. Returns the value if name is found or nil if it is not." + (cdr (header-pair name headers))) + +(defun header-pair (name headers) + "Searchers headers for name _without_ case sensitivity. Headers should be an alist mapping symbols to values; name a symbol. Returns the \(name value\) pair if name is found or nil if it is not." + (assoc name headers + :test (lambda (a b) + (string-equal (symbol-name a) (symbol-name b))))) + +(defun validate-preferred-location () + (typecase *preferred-location* + (null t) + ((integer 0) + (assert (<= 1 *preferred-location* (length *locations*)) + (*preferred-location*) + 'invalid-preferred-location-number-error + :preferred-location *preferred-location*)) + ((or symbol string) + (assert (find *preferred-location* *locations* + :test (if (typep *preferred-location* 'symbol) + #'eq #'string-equal) :key #'third) + (*preferred-location*) + 'invalid-preferred-location-name-error + :preferred-location *preferred-location*)) + (t + (assert nil + (*preferred-location*) + 'invalid-preferred-location-error + :preferred-location *preferred-location*))) + *preferred-location*) + +(defun select-location () + (loop with n-locations = (length *locations*) + for response = (progn + (format t "Install where?~%") + (loop for (source system name) in *locations* + for i from 1 + do (format t "~A) ~A: ~% System in ~A~% Files in ~A ~%" + i name system source)) + (format t "0) Abort installation.~% --> ") + (force-output) + (read)) + when (and (numberp response) + (<= 1 response n-locations)) + return response + when (and (numberp response) + (zerop response)) + do (abort (make-condition 'installation-abort)))) + +(defun install-location () + (validate-preferred-location) + (let ((location-selection (or *preferred-location* + (select-location)))) + (etypecase location-selection + (integer + (elt *locations* (1- location-selection))) + ((or symbol string) + (find location-selection *locations* :key #'third + :test (if (typep location-selection 'string) + #'string-equal #'eq)))))) + + +;;; install-package -- + +(defun find-shell-command (command) + (loop for directory in *shell-search-paths* do + (let ((target (make-pathname :name command :type nil + :directory directory))) + (when (probe-file target) + (return-from find-shell-command (namestring target))))) + (values nil)) + +(defun tar-command () + #-(or :win32 :mswindows) + (find-shell-command *gnu-tar-program*) + #+(or :win32 :mswindows) + *cygwin-bash-program*) + +(defun tar-arguments (source packagename) + #-(or :win32 :mswindows :scl) + (list "-C" (namestring (truename source)) + "-xzvf" (namestring (truename packagename))) + #+(or :win32 :mswindows) + (list "-l" + "-c" + (format nil "\"tar -C \\\"`cygpath '~A'`\\\" -xzvf \\\"`cygpath '~A'`\\\"\"" + (namestring (truename source)) + (namestring (truename packagename)))) + #+scl + (list "-C" (ext:unix-namestring (truename source)) + "-xzvf" (ext:unix-namestring (truename packagename)))) + +(defun extract-using-tar (to-dir tarball) + (let ((tar-command (tar-command))) + (if (and tar-command (probe-file tar-command)) + (return-output-from-program tar-command + (tar-arguments to-dir tarball)) + (warn "Cannot find tar command ~S." tar-command)))) + +(defun extract (to-dir tarball) + (or (some #'(lambda (extractor) (funcall extractor to-dir tarball)) + *tar-extractors*) + (error "Unable to extract tarball ~A." tarball))) + +(defun install-package (source system packagename) + "Returns a list of system names (ASDF or MK:DEFSYSTEM) for installed systems." + (ensure-directories-exist source) + (ensure-directories-exist system) + (let* ((tar (extract source packagename)) + ;; Some tar programs (OSX) list entries with preceeding "x " + ;; as in "x entry/file.asd" + (pos-begin (if (= (search "x " tar) 0) + 2 + 0)) + (pos-slash (or (position #\/ tar) + (position #\Return tar) + (position #\Linefeed tar))) + (*default-pathname-defaults* + (merge-pathnames + (make-pathname :directory + `(:relative ,(subseq tar pos-begin pos-slash))) + source))) + ;(princ tar) + (loop for sysfile in (append + (directory + (make-pathname :defaults *default-pathname-defaults* + :name :wild + :type "asd")) + (directory + (make-pathname :defaults *default-pathname-defaults* + :name :wild + :type "system"))) + do (maybe-symlink-sysfile system sysfile) + do (installer-msg t "Found system definition: ~A" sysfile) + do (maybe-update-central-registry sysfile) + collect sysfile))) + +(defun maybe-update-central-registry (sysfile) + ;; make sure that the systems we install are accessible in case + ;; asdf-install:*locations* and asdf:*central-registry* are out + ;; of sync + (add-registry-location sysfile)) + +(defun temp-file-name (p) + (declare (ignore p)) + (let ((pathname nil)) + (loop for i = 0 then (1+ i) do + (setf pathname + (merge-pathnames + (make-pathname + :name (format nil "asdf-install-~d" i) + :type "asdf-install-tmp") + *temporary-directory*)) + (unless (probe-file pathname) + (return-from temp-file-name pathname))))) + + +;;; install +;;; This is the external entry point. + +(defun install (packages &key (propagate nil) (where *preferred-location*)) + (let* ((*preferred-location* where) + (*temporary-files* nil) + (trusted-uid-file + (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*)) + (*trusted-uids* + (when (probe-file trusted-uid-file) + (with-open-file (f trusted-uid-file) (read f)))) + (old-uids (copy-list *trusted-uids*)) + #+asdf + (*defined-systems* (if propagate + (make-hash-table :test 'equal) + *defined-systems*)) + (packages (if (atom packages) (list packages) packages)) + (*propagate-installation* propagate) + (*systems-installed-this-time* nil)) + (unwind-protect + (destructuring-bind (source system name) (install-location) + (declare (ignore name)) + (labels + ((one-iter (packages) + (let ((packages-to-install nil)) + (loop for p in (mapcar #'string packages) do + (cond ((local-archive-p p) + (setf packages-to-install + (append packages-to-install + (install-package source system p)))) + (t + (multiple-value-bind (package signature) + (download-files-for-package p) + (when (verify-gpg-signatures-p p) + (verify-gpg-signature package signature)) + (installer-msg t "Installing ~A in ~A, ~A" + p source system) + (install-package source system package)) + (setf packages-to-install + (append packages-to-install + (list p)))))) + (dolist (package packages-to-install) + (setf package + (etypecase package + (symbol package) + (string (intern package :asdf-install)) + (pathname (intern + (namestring (pathname-name package)) + :asdf-install)))) + (handler-bind + ( + #+asdf + (asdf:missing-dependency + (lambda (c) + (installer-msg + t + "Downloading package ~A, required by ~A~%" + (asdf::missing-requires c) + (asdf:component-name + (asdf::missing-required-by c))) + (one-iter + (list (asdf::coerce-name + (asdf::missing-requires c)))) + (invoke-restart 'retry))) + #+mk-defsystem + (make:missing-component + (lambda (c) + (installer-msg + t + "Downloading package ~A, required by ~A~%" + (make:missing-component-name c) + package) + (one-iter (list (make:missing-component-name c))) + (invoke-restart 'retry)))) + (loop (multiple-value-bind (ret restart-p) + (with-simple-restart + (retry "Retry installation") + (push package *systems-installed-this-time*) + (load-package package)) + (declare (ignore ret)) + (unless restart-p (return))))))))) + (one-iter packages))) + ;;; cleanup + (unless (equal old-uids *trusted-uids*) + (let ((create-file-p nil)) + (unless (probe-file trusted-uid-file) + (installer-msg t "Trusted UID file ~A does not exist" + (namestring trusted-uid-file)) + (setf create-file-p + (y-or-n-p "Do you want to create the file?"))) + (when (or create-file-p (probe-file trusted-uid-file)) + (ensure-directories-exist trusted-uid-file) + (with-open-file (out trusted-uid-file + :direction :output + :if-exists :supersede) + (with-standard-io-syntax + (prin1 *trusted-uids* out)))))) + (dolist (l *temporary-files* t) + (when (probe-file l) (delete-file l)))) + (nreverse *systems-installed-this-time*))) + +(defun local-archive-p (package) + #+(or :sbcl :allegro) (probe-file package) + #-(or :sbcl :allegro) (and (/= (mismatch package "http://") 7) + (probe-file package))) + +(defun load-package (package) + #+asdf + (progn + (installer-msg t "Loading system ~S via ASDF." package) + (asdf:operate 'asdf:load-op package)) + #+mk-defsystem + (progn + (installer-msg t "Loading system ~S via MK:DEFSYSTEM." package) + (mk:load-system package))) + +;;; uninstall -- + +(defun uninstall (system &optional (prompt t)) + #+asdf + (let* ((asd (asdf:system-definition-pathname system)) + (system (asdf:find-system system)) + (dir (pathname-sans-name+type + (asdf::resolve-symlinks asd)))) + (when (or (not prompt) + (y-or-n-p + "Delete system ~A~%asd file: ~A~%sources: ~A~%Are you sure?" + system asd dir)) + #-(or :win32 :mswindows) + (delete-file asd) + (let ((dir (#-scl namestring #+scl ext:unix-namestring (truename dir)))) + (when dir + (asdf:run-shell-command "rm -r '~A'" dir))))) + + #+mk-defsystem + (multiple-value-bind (sysfile sysfile-exists-p) + (mk:system-definition-pathname system) + (when sysfile-exists-p + (let ((system (ignore-errors (mk:find-system system :error)))) + (when system + (when (or (not prompt) + (y-or-n-p + "Delete system ~A.~%system file: ~A~%Are you sure?" + system + sysfile)) + (mk:clean-system system) + (delete-file sysfile) + (dolist (f (mk:files-in-system system)) + (delete-file f))) + )) + ))) + + +;;; some day we will also do UPGRADE, but we need to sort out version +;;; numbering a bit better first + +#+(and :asdf (or :win32 :mswindows)) +(defun sysdef-source-dir-search (system) + (let ((name (asdf::coerce-name system))) + (dolist (location *locations*) + (let* ((dir (first location)) + (files (directory (merge-pathnames + (make-pathname :name name + :type "asd" + :version :newest + :directory '(:relative :wild) + :host nil + :device nil) + dir)))) + (dolist (file files) + (when (probe-file file) + (return-from sysdef-source-dir-search file))))))) + +(defmethod asdf:find-component :around + ((module (eql nil)) name &optional version) + (declare (ignore version)) + (when (or (not *propagate-installation*) + (member name *systems-installed-this-time* + :test (lambda (a b) + (flet ((ensure-string (x) + (etypecase x + (symbol (symbol-name x)) + (string x)))) + (string-equal (ensure-string a) (ensure-string b)))))) + (call-next-method))) + +(defun show-version-information () + (let ((version (asdf-install-version))) + (if version + (format *standard-output* "~&;;; ASDF-Install version ~A" + version) + (format *standard-output* "~&;;; ASDF-Install version unknown; unable to find ASDF system definition.")) + (values))) + +(defun asdf-install-version () + "Returns the ASDf-Install version information as a string or nil if it cannot be determined." + (let ((system (asdf:find-system 'asdf-install))) + (when system (asdf:component-version system)))) + +;; load customizations if any +(eval-when (:load-toplevel :execute) + (let* ((*package* (find-package :asdf-install-customize)) + (file (probe-file (merge-pathnames + (make-pathname :name ".asdf-install") + (truename (user-homedir-pathname)))))) + (when file (load file)))) + +;;; end of file -- install.lisp -- Added: trunk/abcl/contrib/asdf-install/lift-standard.config ============================================================================== --- (empty file) +++ trunk/abcl/contrib/asdf-install/lift-standard.config Sat Feb 20 07:04:14 2010 @@ -0,0 +1,38 @@ +;;; configuration for LIFT tests + +;; settings +(:if-dribble-exists :supersede) +(:dribble "asdf-install.dribble") +(:print-length 10) +(:print-level 5) +(:print-test-case-names t) + +;; suites to run +(test-asdf-install) + +;; report properties +(:report-property :title "ASDF-Install | Test results") +(:report-property :relative-to test-asdf-install) + + + +(:report-property :style-sheet "test-style.css") +(:report-property :if-exists :supersede) +(:report-property :format :html) +(:report-property :name "test-results/test-report.html") +(:report-property :unique-name t) +(:build-report) + +(:report-property :unique-name t) +(:report-property :format :describe) +(:report-property :name "test-results/test-report.txt") +(:build-report) + + +(:report-property :format :save) +(:report-property :name "test-results/test-report.sav") +(:build-report) + +(:report-property :format :describe) +(:report-property :full-pathname *standard-output*) +(:build-report) Added: trunk/abcl/contrib/asdf-install/load-asdf-install.lisp ============================================================================== --- (empty file) +++ trunk/abcl/contrib/asdf-install/load-asdf-install.lisp Sat Feb 20 07:04:14 2010 @@ -0,0 +1,90 @@ +;;; -*- Mode: Lisp -*- + +;;; load-asdf-install.lisp -- +;;; Generic loader for ASDF-INSTALL. + +(eval-when (:load-toplevel :execute) + (unless (find-package '#:asdf-install-loader) + (make-package '#:asdf-install-loader :use '(#:common-lisp)))) + +(in-package :asdf-install-loader) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *asdf-install-directory* + (make-pathname :host (pathname-host *load-truename*) + :device (pathname-device *load-truename*) + :directory (pathname-directory *load-truename*) + ;; :case :common ; Do we need this? + ))) + + +(defun cl-user::load-asdf-install + (&key + (directory *asdf-install-directory*) + (compile-first-p nil) + (load-verbose *load-verbose*) + (print-herald t) + ) + (when print-herald + (format *standard-output* + "~&;;; ASDF-INSTALL: Loading ASDF-INSTALL package from directory~@ + ;;; \"~A\"~2%" + (namestring (pathname directory)))) + (let ((directory (pathname directory))) + (flet ((load-and-or-compile (file) + (if compile-first-p + (multiple-value-bind (output-truename warnings-p failure-p) + (compile-file file) + ;; (declare (ignore warnings-p)) + (when failure-p + (format *standard-output* + ";;; File ~S compiled~@ + ;;; Warnings ~S, Failure ~S.~%" + output-truename + warnings-p + failure-p) + (return-from cl-user::load-asdf-install nil) + ) + (load output-truename :verbose load-verbose)) + (load file :verbose load-verbose))) + ) + + (setf (logical-pathname-translations "ASDF-INSTALL-LIBRARY") + `(("**;*.*.*" + ,(make-pathname + :host (pathname-host directory) + :device (pathname-device directory) + :directory (append (pathname-directory directory) + (list :wild-inferiors)))) + ("**;*.*" + ,(make-pathname + :host (pathname-host directory) + :device (pathname-device directory) + :directory (append (pathname-directory directory) + (list :wild-inferiors)))))) + + (load-and-or-compile "ASDF-INSTALL-LIBRARY:defpackage.lisp") + (load-and-or-compile "ASDF-INSTALL-LIBRARY:port.lisp") + + (unless (find-package '#:split-sequence) + (load-and-or-compile "ASDF-INSTALL-LIBRARY:split-sequence.lisp")) + + (load-and-or-compile "ASDF-INSTALL-LIBRARY:installer.lisp") + + ;; (load-and-or-compile "ASDF-INSTALL-LIBRARY:loader.lisp") + + )) + (pushnew :asdf-install *features*) + (provide 'asdf-install) + + ;; To clean a minimum (and to make things difficult to debug)... + ;; (delete-package '#:asdf-install-loader) + ) + + +;;; Automatically load the library. + +(eval-when (:load-toplevel :execute) + (cl-user::load-asdf-install)) + +;;; end of file -- load-asdf-install.lisp -- Added: trunk/abcl/contrib/asdf-install/loader.lisp ============================================================================== --- (empty file) +++ trunk/abcl/contrib/asdf-install/loader.lisp Sat Feb 20 07:04:14 2010 @@ -0,0 +1,20 @@ +(in-package :cl-user) + +(eval-when (:load-toplevel) + (unless (find-package 'asdf) + (require 'asdf))) + +(eval-when (:load-toplevel) + (unless (find-package 'asdf) + (error "ASDF-Install requires ASDF to load")) + (let ((asdf::*verbose-out* nil)) + (require 'asdf-install))) + +#+sbcl +(defun run () + (handler-case + (apply #'asdf-install:install (cdr *posix-argv*)) + (error (c) + (format *error-output* "Install failed due to error:~% ~A~%" c) + (sb-ext:quit :unix-status 1)))) + Added: trunk/abcl/contrib/asdf-install/port.lisp ============================================================================== --- (empty file) +++ trunk/abcl/contrib/asdf-install/port.lisp Sat Feb 20 07:04:14 2010 @@ -0,0 +1,516 @@ +(in-package #:asdf-install) + +(defvar *temporary-files*) + +(defparameter *shell-path* "/bin/sh" + "The path to a Bourne compatible command shell in physical pathname notation.") + +(eval-when (:load-toplevel :compile-toplevel :execute) + #+:allegro + (require :osi) + #+:allegro + (require :socket) + #+:digitool + (require :opentransport) + #+:ecl + (require :sockets) + #+:lispworks + (require "comm") + ) + +(defun get-env-var (name) + #+:allegro (sys:getenv name) + #+:clisp (ext:getenv name) + #+:cmu (cdr (assoc (intern (substitute #\_ #\- name) + :keyword) + ext:*environment-list*)) + #+:ecl (ext:getenv name) + #+:lispworks (lw:environment-variable name) + #+(or :mcl :openmcl) (ccl::getenv name) + #+:sbcl (sb-ext:posix-getenv name) + #+:scl (cdr (assoc name ext:*environment-list* :test #'string=)) + #+abcl (ext:getenv name) + ) + +#-:digitool +(defun system-namestring (pathname) + (namestring (truename pathname))) + +#+:digitool +(defvar *start-up-volume* + (second (pathname-directory (truename "ccl:")))) + +#+:digitool +(defun system-namestring (pathname) + ;; this tries to adjust the root directory to eliminate the spurious + ;; volume name for the boot file system; it also avoids use of + ;; TRUENAME as some applications are for not yet existent files + (let ((truename (probe-file pathname))) + (unless truename + (setf truename + (translate-logical-pathname + (merge-pathnames pathname *default-pathname-defaults*)))) + (let ((directory (pathname-directory truename))) + (flet ((string-or-nil (value) (when (stringp value) value)) + (absolute-p (directory) (eq (first directory) :absolute)) + (root-volume-p (directory) + (equal *start-up-volume* (second directory)))) + (format nil "~:[~;/~]~{~a/~}~@[~a~]~@[.~a~]" + (absolute-p directory) + (if (root-volume-p directory) (cddr directory) (cdr directory)) + (string-or-nil (pathname-name truename)) + (string-or-nil (pathname-type truename))))))) + +#+:digitool +(progn + (defun |read-linefeed-eol-comment| + (stream char &optional (eol '(#\return #\linefeed))) + (loop (setf char (read-char stream nil nil)) + (unless char (return)) + (when (find char eol) (return))) + (values)) + + (set-syntax-from-char #\linefeed #\space) + (set-macro-character #\; #'|read-linefeed-eol-comment| nil *readtable*)) + +;; for non-SBCL we just steal this from SB-EXECUTABLE +#-(or :digitool) +(defvar *stream-buffer-size* 8192) +#-(or :digitool) +(defun copy-stream (from to) + "Copy into TO from FROM until end of the input stream, in blocks of +*stream-buffer-size*. The streams should have the same element type." + (unless (subtypep (stream-element-type to) (stream-element-type from)) + (error "Incompatible streams ~A and ~A." from to)) + (let ((buf (make-array *stream-buffer-size* + :element-type (stream-element-type from)))) + (loop + (let ((pos #-(or :clisp :cmu) (read-sequence buf from) + #+:clisp (ext:read-byte-sequence buf from :no-hang nil) + #+:cmu (sys:read-n-bytes from buf 0 *stream-buffer-size* nil))) + (when (zerop pos) (return)) + (write-sequence buf to :end pos))))) + +#+:digitool +(defun copy-stream (from to) + "Perform copy and map EOL mode." + (multiple-value-bind (reader reader-arg) (ccl::stream-reader from) + (multiple-value-bind (writer writer-arg) (ccl::stream-writer to) + (let ((datum nil)) + (loop (unless (setf datum (funcall reader reader-arg)) + (return)) + (funcall writer writer-arg datum)))))) + +(defun make-stream-from-url (url) + #+(or :sbcl :ecl) + (let ((s (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (sb-bsd-sockets:socket-connect + s (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name (url-host url)))) + (url-port url)) + (sb-bsd-sockets:socket-make-stream + s + :input t + :output t + :buffering :full + :external-format :iso-8859-1)) + #+:cmu + (sys:make-fd-stream (ext:connect-to-inet-socket (url-host url) (url-port url)) + :input t :output t :buffering :full) + #+:scl + (sys:make-fd-stream (ext:connect-to-inet-socket (url-host url) (url-port url)) + :input t :output t :buffering :full + :external-format :iso-8859-1) + #+:lispworks + (comm:open-tcp-stream (url-host url) (url-port url) + #+(and :lispworks :win32) :element-type + #+(and :lispworks :win32) '(unsigned-byte 8)) + #+:allegro + (socket:make-socket :remote-host (url-host url) + :remote-port (url-port url)) + #+:clisp + (socket:socket-connect (url-port url) (url-host url) + :external-format + (ext:make-encoding :charset 'charset:iso-8859-1 :line-terminator :unix)) + #+:openmcl + (ccl:make-socket :remote-host (url-host url) + :remote-port (url-port url)) + #+:digitool + (ccl::open-tcp-stream (url-host url) (url-port url) + :element-type 'unsigned-byte) + + #+:abcl + (let ((socket + (ext:make-socket (url-host url) (url-port url)))) + (ext:get-socket-stream socket))) + + +#+:sbcl +(defun return-output-from-program (program args) + (with-output-to-string (out-stream) + (let ((proc (sb-ext:run-program + program + args + :output out-stream + :search t + :wait t))) + (when (or (null proc) + (and (member (sb-ext:process-status proc) '(:exited :signaled)) + (not (zerop (sb-ext:process-exit-code proc))))) + (return-from return-output-from-program nil))))) + +#+(or :cmu :scl) +(defun return-output-from-program (program args) + (with-output-to-string (out-stream) + (let ((proc (ext:run-program + program + args + :output out-stream + :wait t))) + (when (or (null proc) + (and (member (ext:process-status proc) '(:exited :signaled)) + (not (zerop (ext:process-exit-code proc))))) + (return-from return-output-from-program nil))))) + +#+:lispworks +(defun return-output-from-program (program args) + (with-output-to-string (out-stream) + (unless (zerop (sys:call-system-showing-output + (format nil #-:win32 "~A~{ '~A'~}" + #+:win32 "~A~{ ~A~}" + program args) + :prefix "" + :show-cmd nil + :output-stream out-stream)) + (return-from return-output-from-program nil)))) + +#+(and :clisp (not :win32)) +(defun return-output-from-program (program args) + (with-output-to-string (out-stream) + (let ((stream + (ext:run-program program + :arguments args + :output :stream + :wait nil))) + (loop for line = (read-line stream nil) + while line + do (write-line line out-stream))))) + +#+(and :clisp :win32) +(defun return-output-from-program (program args) + (with-output-to-string (out-stream) + (let ((stream + (ext:run-shell-command + (format nil "~A~{ ~A~}" program args + :output :stream + :wait nil)))) + (loop for line = (ignore-errors (read-line stream nil)) + while line + do (write-line line out-stream))))) + +#+:allegro +(defun return-output-from-program (program args) + (with-output-to-string (out-stream) + (let ((stream + (excl:run-shell-command + #-:mswindows + (concatenate 'vector + (list program) + (cons program args)) + #+:mswindows + (format nil "~A~{ ~A~}" program args) + :output :stream + :wait nil))) + (loop for line = (read-line stream nil) + while line + do (write-line line out-stream))))) + +#+:ecl +(defun return-output-from-program (program args) + (with-output-to-string (out-stream) + (let ((stream (ext:run-program program args :output :stream))) + (when stream + (loop for line = (ignore-errors (read-line stream nil)) + while line + do (write-line line out-stream)))))) + +#+:openmcl +(defun return-output-from-program (program args) + (with-output-to-string (out-stream) + (let ((proc (ccl:run-program program args + :input nil + :output :stream + :wait nil))) + (loop for line = (read-line + (ccl:external-process-output-stream proc) nil nil nil) + while line + do (write-line line out-stream))))) + +#+:digitool +(defun return-output-from-program (program args) + (ccl::call-system (format nil "~A~{ '~A'~} 2>&1" program args))) + +#+:abcl +(defun return-output-from-program (program args) + (let ((command (format nil "~A ~{ '~A' ~}" program args))) + (with-output-to-string (out-stream) + (ext:run-shell-command command :output out-stream)))) + + +(defun unlink-file (pathname) + ;; 20070208 gwking at metabang.com - removed lisp-specific os-level calls + ;; in favor of a simple delete + (delete-file pathname)) + +(defun symlink-files (old new) + (let* ((old (#-scl namestring #+scl ext:unix-namestring old)) + (new (#-scl namestring #+scl ext:unix-namestring new #+scl nil)) + ;; 20070811 - thanks to Juan Jose Garcia-Ripoll for pointing + ;; that ~a would wreck havoc if the working directory had a space + ;; in the pathname + (command (format nil "ln -s ~s ~s" old new))) + (format t "~S~%" command) + (shell-command command))) + +(defun maybe-symlink-sysfile (system sysfile) + (declare (ignorable system sysfile)) + #-(or :win32 :mswindows) + (let ((target (merge-pathnames + (make-pathname :name (pathname-name sysfile) + :type (pathname-type sysfile)) + system))) + (when (probe-file target) + (unlink-file target)) + (symlink-files sysfile target))) + +;;; --------------------------------------------------------------------------- +;;; read-header-line +;;; --------------------------------------------------------------------------- + +#-:digitool +(defun read-header-line (stream) + (read-line stream)) + +#+:digitool +(defun read-header-line (stream &aux (line (make-array 16 + :element-type 'character + :adjustable t + :fill-pointer 0)) + (byte nil)) + (print (multiple-value-bind (reader arg) + (ccl::stream-reader stream) + (loop (setf byte (funcall reader arg)) + (case byte + ((nil) + (return)) + ((#.(char-code #\Return) + #.(char-code #\Linefeed)) + (case (setf byte (funcall reader arg)) + ((nil #.(char-code #\Return) #.(char-code #\Linefeed))) + (t (ccl:stream-untyi stream byte))) + (return)) + (t + (vector-push-extend (code-char byte) line)))) + (when (or byte (plusp (length line))) + line)))) + +(defun open-file-arguments () + (append + #+sbcl + '(:external-format :latin1) + #+:scl + '(:external-format :iso-8859-1) + #+(or :clisp :digitool (and :lispworks :win32)) + '(:element-type (unsigned-byte 8)))) + +(defun download-url-to-file (url file-name) + "Resolves url and then downloads it to file-name; returns the url actually used." + (multiple-value-bind (response headers stream) + (loop + (destructuring-bind (response headers stream) + (url-connection url) + (unless (member response '(301 302)) + (return (values response headers stream))) + (close stream) + (setf url (header-value :location headers)))) + (when (>= response 400) + (error 'download-error :url url :response response)) + (let ((length (parse-integer (or (header-value :content-length headers) "") + :junk-allowed t))) + (installer-msg t "Downloading ~A bytes from ~A to ~A ..." + (or length "some unknown number of") + url + file-name) + (force-output) + #+:clisp (setf (stream-element-type stream) + '(unsigned-byte 8)) + (let ((ok? nil) (o nil)) + (unwind-protect + (progn + (setf o (apply #'open file-name + :direction :output :if-exists :supersede + (open-file-arguments))) + #+(or :cmu :digitool) + (copy-stream stream o) + #-(or :cmu :digitool) + (if length + (let ((buf (make-array length + :element-type + (stream-element-type stream)))) + #-:clisp (read-sequence buf stream) + #+:clisp (ext:read-byte-sequence buf stream :no-hang nil) + (write-sequence buf o)) + (copy-stream stream o)) + (setf ok? t)) + (when o (close o :abort (null ok?)))))) + (close stream)) + (values url)) + +(defun download-url-to-temporary-file (url) + "Attempts to download url to a new, temporary file. Returns the resolved url and the file name \(as multiple values\)." + (let ((tmp (temp-file-name url))) + (pushnew tmp *temporary-files*) + (values (download-url-to-file url tmp) tmp))) + +(defun gpg-results (package signature) + (let ((tags nil)) + (with-input-from-string + (gpg-stream + (shell-command (format nil "~s --status-fd 1 --verify ~s ~s" + *gpg-command* + (namestring signature) (namestring package)))) + (loop for l = (read-line gpg-stream nil nil) + while l + do (print l) + when (> (mismatch l "[GNUPG:]") 6) + do (destructuring-bind (_ tag &rest data) + (split-sequence-if (lambda (x) + (find x '(#\Space #\Tab))) + l) + (declare (ignore _)) + (pushnew (cons (intern (string-upcase tag) :keyword) + data) tags))) + tags))) + +#+allegro +(defun shell-command (command) + (multiple-value-bind (output error status) + (excl.osi:command-output command :whole t) + (values output error status))) + +#+clisp +(defun shell-command (command) + ;; BUG: CLisp doesn't allow output to user-specified stream + (values + nil + nil + (ext:run-shell-command command :output :terminal :wait t))) + +#+(or :cmu :scl) +(defun shell-command (command) + (let* ((process (ext:run-program + *shell-path* + (list "-c" command) + :input nil :output :stream :error :stream)) + (output (file-to-string-as-lines (ext::process-output process))) + (error (file-to-string-as-lines (ext::process-error process)))) + (close (ext::process-output process)) + (close (ext::process-error process)) + (values + output + error + (ext::process-exit-code process)))) + +#+ecl +(defun shell-command (command) + ;; If we use run-program, we do not get exit codes + (values nil nil (ext:system command))) + +#+lispworks +(defun shell-command (command) + ;; BUG: Lispworks combines output and error streams + (let ((output (make-string-output-stream))) + (unwind-protect + (let ((status + (system:call-system-showing-output + command + :prefix "" + :show-cmd nil + :output-stream output))) + (values (get-output-stream-string output) nil status)) + (close output)))) + +#+openmcl +(defun shell-command (command) + (let* ((process (create-shell-process command t)) + (output (file-to-string-as-lines + (ccl::external-process-output-stream process))) + (error (file-to-string-as-lines + (ccl::external-process-error-stream process)))) + (close (ccl::external-process-output-stream process)) + (close (ccl::external-process-error-stream process)) + (values output + error + (process-exit-code process)))) + +#+openmcl +(defun create-shell-process (command wait) + (ccl:run-program + *shell-path* + (list "-c" command) + :input nil :output :stream :error :stream + :wait wait)) + +#+openmcl +(defun process-exit-code (process) + (nth-value 1 (ccl:external-process-status process))) + +#+digitool +(defun shell-command (command) + ;; BUG: I have no idea what this returns + (ccl::call-system command)) + +#+sbcl +(defun shell-command (command) + (let* ((process (sb-ext:run-program + *shell-path* + (list "-c" command) + :input nil :output :stream :error :stream)) + (output (file-to-string-as-lines (sb-impl::process-output process))) + (error (file-to-string-as-lines (sb-impl::process-error process)))) + (close (sb-impl::process-output process)) + (close (sb-impl::process-error process)) + (values + output + error + (sb-impl::process-exit-code process)))) + +#+:abcl +(defun shell-command (command) + (let* ((output (make-string-output-stream)) + (status + (ext:run-shell-command command :output output))) + (values (get-output-stream-string output) nil (format nil "~A" status)))) + +(defgeneric file-to-string-as-lines (pathname) + (:documentation "")) + +(defmethod file-to-string-as-lines ((pathname pathname)) + (with-open-file (stream pathname :direction :input) + (file-to-string-as-lines stream))) + +(defmethod file-to-string-as-lines ((stream stream)) + (with-output-to-string (s) + (loop for line = (read-line stream nil :eof nil) + until (eq line :eof) do + (princ line s) + (terpri s)))) + +;; copied from ASDF +(defun pathname-sans-name+type (pathname) + "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, +and NIL NAME and TYPE components" + (make-pathname :name nil :type nil :defaults pathname)) + Added: trunk/abcl/contrib/asdf-install/split-sequence.lisp ============================================================================== --- (empty file) +++ trunk/abcl/contrib/asdf-install/split-sequence.lisp Sat Feb 20 07:04:14 2010 @@ -0,0 +1,59 @@ +;;;; SPLIT-SEQUENCE +;;; +;;; This code was based on Arthur Lemmens' in +;;; ; +;;; + +(in-package #:asdf-install) + +(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) + "Return a list of subsequences in seq delimited by items satisfying +predicate. + +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE-IF. In particular, the +behaviour of :from-end is possibly different from other versions of +this function; :from-end values of NIL and T are equivalent unless +:count is supplied. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped." + (let ((len (length seq)) + (other-keys (when key-supplied + (list :key key)))) + (unless end (setq end len)) + (if from-end + (loop for right = end then left + for left = (max (or (apply #'position-if predicate seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left)) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values (nreverse subseqs) right) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (< left start) + finally (return (values (nreverse subseqs) (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position-if predicate seq + :start left + other-keys) + len) + end) + unless (and (= right left) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values subseqs left) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (>= right end) + finally (return (values subseqs right)))))) + Added: trunk/abcl/contrib/asdf-install/variables.lisp ============================================================================== --- (empty file) +++ trunk/abcl/contrib/asdf-install/variables.lisp Sat Feb 20 07:04:14 2010 @@ -0,0 +1,122 @@ +(in-package #:asdf-install) + +(defun directorify (name) + ;; input name may or may not have a trailing #\/, but we know we + ;; want a directory + (let ((path (pathname name))) + (if (pathname-name path) + (merge-pathnames + (make-pathname :directory `(:relative ,(pathname-name path)) + :name "") + path) + path))) + +#+:digitool +(defparameter *home-volume-name* + (second (pathname-directory (truename (user-homedir-pathname)))) + "Digitool MCL retains the OS 9 convention that ALL volumes have a +name which includes the startup volume. OS X doesn't know about this. +This figures in the home path and in the normalization for system +namestrings.") + +(defvar *proxy* (get-env-var "http_proxy")) + +(defvar *proxy-user* nil) + +(defvar *proxy-passwd* nil) + +(defvar *trusted-uids* nil) + +(defvar *verify-gpg-signatures* t + "Can be t, nil, or :unknown-locations. If true, then the signature of all packages will be checked. If nil, then no signatures will be checked. If :unkown-locations, then only packages whose location is not a prefix of any `*safe-url-prefixes*` will be tested.") + +(defvar *safe-url-prefixes* nil) + +(defvar *preferred-location* nil) + +(defvar *cclan-mirror* + (or (get-env-var "CCLAN_MIRROR") + "http://ftp.linux.org.uk/pub/lisp/cclan/")) + +#+(or :win32 :mswindows) +(defvar *cygwin-bin-directory* + (pathname "C:\\PROGRA~1\\Cygwin\\bin\\")) + +#+(or :win32 :mswindows) +(defvar *cygwin-bash-program* + "C:\\PROGRA~1\\Cygwin\\bin\\bash.exe") + +;; bin first +(defvar *shell-search-paths* '((:absolute "bin") + (:absolute "usr" "bin")) + "A list of places to look for shell commands.") + +(defvar *gnu-tar-program* + #-(or :netbsd :freebsd :solaris) "tar" + #+(or :netbsd :freebsd :solaris) "gtar" + "Path to the GNU tar program") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *supported-defsystems* + (list :mk-defsystem + :asdf + + ;; Add others. + ;; #+lispworks :common-defsystem + ;; #+gbbopen :mini-module + )) + (unless (some (lambda (defsys-tag) + (member defsys-tag *features*)) + *features*) + (error "ASDF-INSTALL requires one of the following \"defsystem\" utilities to work: ~A" + *supported-defsystems*))) + +(defvar *asdf-install-dirs* + (directorify (or #+sbcl (get-env-var "SBCL_HOME") + (get-env-var "ASDF_INSTALL_DIR") + (make-pathname :directory + `(:absolute + #+digitool ,*home-volume-name* + "usr" "local" "asdf-install"))))) + +(defvar *private-asdf-install-dirs* + #+:sbcl + (merge-pathnames (make-pathname :directory '(:relative ".sbcl")) + (truename (user-homedir-pathname))) + #-:sbcl + (cond ((get-env-var "PRIVATE_ASDF_INSTALL_DIR") + (directorify (get-env-var "PRIVATE_ASDF_INSTALL_DIR"))) + (t + (merge-pathnames (make-pathname + :directory '(:relative ".asdf-install-dir")) + (truename (user-homedir-pathname)))))) + +(defparameter *locations* + `((,(merge-pathnames (make-pathname :directory '(:relative "site")) + *asdf-install-dirs*) + ,(merge-pathnames (make-pathname :directory '(:relative "site-systems")) + *asdf-install-dirs*) + "System-wide install") + (,(merge-pathnames (make-pathname :directory '(:relative "site")) + *private-asdf-install-dirs*) + ,(merge-pathnames (make-pathname :directory '(:relative "systems")) + *private-asdf-install-dirs*) + "Personal installation"))) + +(defvar *tar-extractors* + '(extract-using-tar)) + +(defvar *systems-installed-this-time* nil + "Used during installation propagation \(see *propagate-installation*\) to keep track off which systems have been installed during the current call to install.") + +(defvar *propagate-installation* nil + "If true, then every required system will be re-asdf-installed.") + +(defvar *temporary-directory* + (pathname-sans-name+type (user-homedir-pathname))) + +(defvar *gpg-command* "gpg" + "Location of the gpg binary, if for some reason, it does appear in + the default path for /bin/sh.") + + From vvoutilainen at common-lisp.net Sat Feb 20 17:28:55 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sat, 20 Feb 2010 12:28:55 -0500 Subject: [armedbear-cvs] r12488 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sat Feb 20 12:28:52 2010 New Revision: 12488 Log: 1) remove copy-paste code, consolidate index and char array extraction 2) make string= use Arrays.equals 3) implement index-version of string= in terms of string/= 4) implement string-equal in terms of string-not-equal 5) implement string> in terms of string< 6) implement string>= in terms of string<= The work will continue by doing string-lessp and string-greaterp in terms of one of them, same for string-not-lessp and string-not-greterp and so on. Thanks to Alessio Stalla for explaining how the various indices work. Modified: trunk/abcl/src/org/armedbear/lisp/StringFunctions.java Modified: trunk/abcl/src/org/armedbear/lisp/StringFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StringFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StringFunctions.java Sat Feb 20 12:28:52 2010 @@ -34,8 +34,41 @@ package org.armedbear.lisp; import static org.armedbear.lisp.Lisp.*; - +import java.util.Arrays; public final class StringFunctions { + private final static class StringIndicesAndChars { + + public char[] array1; + public char[] array2; + public int start1 = 0; + public int end1; + public int start2 = 0; + public int end2; + }; + private final static StringIndicesAndChars + stringIndicesAndChars(LispObject... params) { + StringIndicesAndChars retVal = new StringIndicesAndChars(); + retVal.array1 = params[0].STRING().getStringChars(); + retVal.array2 = params[1].STRING().getStringChars(); + retVal.end1 = retVal.array1.length; + retVal.end2 = retVal.array2.length; + if (params.length > 2) { + if (params[2] != NIL) { + retVal.start1 = Fixnum.getValue(params[2]); + } + if (params[3] != NIL) { + retVal.end1 = Fixnum.getValue(params[3]); + } + if (params[4] != NIL) { + retVal.start2 = Fixnum.getValue(params[4]); + } + if (params[5] != NIL) { + retVal.end2 = Fixnum.getValue(params[5]); + } + } + return retVal; + } + // ### %string= // Case sensitive. private static final Primitive _STRING_EQUAL = new pf__string_equal(); @@ -50,34 +83,10 @@ LispObject fifth, LispObject sixth) { - char[] array1 = first.STRING().getStringChars(); - char[] array2 = second.STRING().getStringChars(); - int start1, end1, start2, end2; - start1 = Fixnum.getValue(third); - if (fourth == NIL) { - end1 = array1.length; - } else { - end1 = Fixnum.getValue(fourth); - } - start2 = Fixnum.getValue(fifth); - if (sixth == NIL) { - end2 = array2.length; - } else { - end2 = Fixnum.getValue(sixth); - } - if ((end1 - start1) != (end2 - start2)) - return NIL; - try { - for (int i = start1, j = start2; i < end1; i++, j++) { - if (array1[i] != array2[j]) - return NIL; - } - } catch (ArrayIndexOutOfBoundsException e) { - // Shouldn't happen. - Debug.trace(e); - return NIL; - } - return T; + return + (_STRING_NOT_EQUAL.execute(first, second, third, + fourth, fifth, sixth) + == NIL) ? T : NIL; } }; @@ -93,17 +102,11 @@ public LispObject execute(LispObject first, LispObject second) { - char[] array1 = first.STRING().getStringChars(); - char[] array2 = second.STRING().getStringChars(); - if (array1.length != array2.length) - return NIL; - for (int i = array1.length; i-- > 0;) { - if (array1[i] != array2[i]) - return NIL; - } - return T; - } - }; + StringIndicesAndChars chars = stringIndicesAndChars(first, second); + return Arrays.equals(chars.array1, chars.array2) ? + T : NIL; + }; + } // ### %string/= // Case sensitive. @@ -114,29 +117,26 @@ } @Override - public LispObject execute(LispObject[] args) { - if (args.length != 6) - return error(new WrongNumberOfArgumentsException(this)); - char[] array1 = args[0].STRING().getStringChars(); - char[] array2 = args[1].STRING().getStringChars(); - int start1 = Fixnum.getValue(args[2]); - int end1 = Fixnum.getValue(args[3]); - int start2 = Fixnum.getValue(args[4]); - int end2 = Fixnum.getValue(args[5]); - int i = start1; - int j = start2; + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) { + StringIndicesAndChars indicesAndChars = + stringIndicesAndChars(first, second, third, fourth, + fifth, sixth); + int i = indicesAndChars.start1; + int j = indicesAndChars.start2; while (true) { - if (i == end1) { + if (i == indicesAndChars.end1) { // Reached end of string1. - if (j == end2) + if (j == indicesAndChars.end2) return NIL; // Strings are identical. return Fixnum.getInstance(i); } - if (j == end2) { + if (j == indicesAndChars.end2) { // Reached end of string2 before end of string1. return Fixnum.getInstance(i); } - if (array1[i] != array2[j]) + if (indicesAndChars.array1[i] != indicesAndChars.array2[j]) return Fixnum.getInstance(i); ++i; ++j; @@ -158,32 +158,14 @@ LispObject fifth, LispObject sixth) { - char[] array1 = first.STRING().getStringChars(); - char[] array2 = second.STRING().getStringChars(); - int start1 = Fixnum.getValue(third); - int end1 = Fixnum.getValue(fourth); - int start2 = Fixnum.getValue(fifth); - int end2 = Fixnum.getValue(sixth); - if ((end1 - start1) != (end2 - start2)) - return NIL; - int i, j; - for (i = start1, j = start2; i < end1; i++, j++) { - char c1 = array1[i]; - char c2 = array2[j]; - if (c1 == c2) - continue; - if (LispCharacter.toUpperCase(c1) == LispCharacter.toUpperCase(c2)) - continue; - if (LispCharacter.toLowerCase(c1) == LispCharacter.toLowerCase(c2)) - continue; - return NIL; - } - return T; + return (_STRING_NOT_EQUAL_IGNORE_CASE.execute(first, second, third, + fourth, fifth, sixth) + == NIL) ? T : NIL; } }; // ### %string-not-equal - // Case sensitive. + // Case insensitive. private static final Primitive _STRING_NOT_EQUAL_IGNORE_CASE = new pf__string_not_equal_ignore_case(); private static final class pf__string_not_equal_ignore_case extends Primitive { pf__string_not_equal_ignore_case() { @@ -191,30 +173,27 @@ } @Override - public LispObject execute(LispObject[] args) { - if (args.length != 6) - return error(new WrongNumberOfArgumentsException(this)); - char[] array1 = args[0].STRING().getStringChars(); - char[] array2 = args[1].STRING().getStringChars(); - int start1 = Fixnum.getValue(args[2]); - int end1 = Fixnum.getValue(args[3]); - int start2 = Fixnum.getValue(args[4]); - int end2 = Fixnum.getValue(args[5]); - int i = start1; - int j = start2; + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) { + StringIndicesAndChars indicesAndChars = + stringIndicesAndChars(first, second, third, fourth, + fifth, sixth); + int i = indicesAndChars.start1; + int j = indicesAndChars.start2; while (true) { - if (i == end1) { + if (i == indicesAndChars.end1) { // Reached end of string1. - if (j == end2) + if (j == indicesAndChars.end2) return NIL; // Strings are identical. return Fixnum.getInstance(i); } - if (j == end2) { + if (j == indicesAndChars.end2) { // Reached end of string2. return Fixnum.getInstance(i); } - char c1 = array1[i]; - char c2 = array2[j]; + char c1 = indicesAndChars.array1[i]; + char c2 = indicesAndChars.array2[j]; if (c1 == c2 || LispCharacter.toUpperCase(c1) == LispCharacter.toUpperCase(c2) || LispCharacter.toLowerCase(c1) == LispCharacter.toLowerCase(c2)) { @@ -229,6 +208,33 @@ // ### %string< // Case sensitive. + private static int lessThan(StringIndicesAndChars indicesAndChars) { + int i = indicesAndChars.start1; + int j = indicesAndChars.start2; + while (true) { + if (i == indicesAndChars.end1) { + // Reached end of string1. + if (j == indicesAndChars.end2) + return -1; // Strings are identical. + return i; + } + if (j == indicesAndChars.end2) { + // Reached end of string2. + return -1; + } + char c1 = indicesAndChars.array1[i]; + char c2 = indicesAndChars.array2[j]; + if (c1 == c2) { + ++i; + ++j; + continue; + } + if (c1 < c2) + return (i); + // c1 > c2 + return -1; + } + } private static final Primitive _STRING_LESS_THAN = new pf__string_less_than(); private static final class pf__string_less_than extends Primitive { pf__string_less_than() { @@ -236,44 +242,18 @@ } @Override - public LispObject execute(LispObject[] args) { - if (args.length != 6) - return error(new WrongNumberOfArgumentsException(this)); - char[] array1 = args[0].STRING().getStringChars(); - char[] array2 = args[1].STRING().getStringChars(); - int start1 = Fixnum.getValue(args[2]); - int end1 = Fixnum.getValue(args[3]); - int start2 = Fixnum.getValue(args[4]); - int end2 = Fixnum.getValue(args[5]); - int i = start1; - int j = start2; - while (true) { - if (i == end1) { - // Reached end of string1. - if (j == end2) - return NIL; // Strings are identical. - return Fixnum.getInstance(i); - } - if (j == end2) { - // Reached end of string2. - return NIL; - } - char c1 = array1[i]; - char c2 = array2[j]; - if (c1 == c2) { - ++i; - ++j; - continue; - } - if (c1 < c2) - return Fixnum.getInstance(i); - // c1 > c2 - return NIL; - } + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) { + StringIndicesAndChars indicesAndChars = + stringIndicesAndChars(first, second, third, + fourth, fifth, sixth); + int retVal = lessThan(indicesAndChars); + return (retVal >= 0) ? Fixnum.getInstance(retVal) : NIL; } }; - // ### %string<= + // ### %string> // Case sensitive. private static final Primitive _STRING_GREATER_THAN = new pf__string_greater_than(); private static final class pf__string_greater_than extends Primitive { @@ -282,41 +262,48 @@ } @Override - public LispObject execute(LispObject[] args) { - if (args.length != 6) - return error(new WrongNumberOfArgumentsException(this)); - char[] array1 = args[0].STRING().getStringChars(); - char[] array2 = args[1].STRING().getStringChars(); - int start1 = Fixnum.getValue(args[2]); - int end1 = Fixnum.getValue(args[3]); - int start2 = Fixnum.getValue(args[4]); - int end2 = Fixnum.getValue(args[5]); - int i = start1; - int j = start2; - while (true) { - if (i == end1) { - // Reached end of string1. - return NIL; - } - if (j == end2) { - // Reached end of string2. - return Fixnum.getInstance(i); - } - char c1 = array1[i]; - char c2 = array2[j]; - if (c1 == c2) { - ++i; - ++j; - continue; - } - if (c1 < c2) - return NIL; - // c1 > c2 - return Fixnum.getInstance(i); + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) { + // note the swap of the strings and lengths here.. + StringIndicesAndChars indicesAndChars = + stringIndicesAndChars(second, first, + fifth, sixth, + third, fourth); + int tmp = lessThan(indicesAndChars); + if (tmp < 0) { + return NIL; + } + int delta = tmp - indicesAndChars.start1; + int retVal = indicesAndChars.start2 + delta; + return Fixnum.getInstance(retVal); + } + }; + private static int lessThanOrEqual(StringIndicesAndChars indicesAndChars) { + int i = indicesAndChars.start1; + int j = indicesAndChars.start2; + while (true) { + if (i == indicesAndChars.end1) { + // Reached end of string1. + return i; + } + if (j == indicesAndChars.end2) { + // Reached end of string2. + return -1; + } + char c1 = indicesAndChars.array1[i]; + char c2 = indicesAndChars.array2[j]; + if (c1 == c2) { + ++i; + ++j; + continue; } + if (c1 > c2) + return -1; + // c1 < c2 + return (i); } - }; - + } // ### %string<= // Case sensitive. private static final Primitive _STRING_LE = new pf__string_le(); @@ -326,42 +313,19 @@ } @Override - public LispObject execute(LispObject[] args) { - if (args.length != 6) - return error(new WrongNumberOfArgumentsException(this)); - char[] array1 = args[0].STRING().getStringChars(); - char[] array2 = args[1].STRING().getStringChars(); - int start1 = Fixnum.getValue(args[2]); - int end1 = Fixnum.getValue(args[3]); - int start2 = Fixnum.getValue(args[4]); - int end2 = Fixnum.getValue(args[5]); - int i = start1; - int j = start2; - while (true) { - if (i == end1) { - // Reached end of string1. - return Fixnum.getInstance(i); - } - if (j == end2) { - // Reached end of string2. - return NIL; - } - char c1 = array1[i]; - char c2 = array2[j]; - if (c1 == c2) { - ++i; - ++j; - continue; - } - if (c1 > c2) - return NIL; - // c1 < c2 - return Fixnum.getInstance(i); - } + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) { + + StringIndicesAndChars indicesAndChars = + stringIndicesAndChars(first, second, third, + fourth, fifth, sixth); + int retVal = lessThanOrEqual(indicesAndChars); + return (retVal >= 0) ? Fixnum.getInstance(retVal) : NIL; } }; - // ### %string<= + // ### %string>= // Case sensitive. private static final Primitive _STRING_GE = new pf__string_ge(); private static final class pf__string_ge extends Primitive { @@ -370,40 +334,21 @@ } @Override - public LispObject execute(LispObject[] args) { - if (args.length != 6) - return error(new WrongNumberOfArgumentsException(this)); - char[] array1 = args[0].STRING().getStringChars(); - char[] array2 = args[1].STRING().getStringChars(); - int start1 = Fixnum.getValue(args[2]); - int end1 = Fixnum.getValue(args[3]); - int start2 = Fixnum.getValue(args[4]); - int end2 = Fixnum.getValue(args[5]); - int i = start1; - int j = start2; - while (true) { - if (i == end1) { - // Reached end of string1. - if (j == end2) - return Fixnum.getInstance(i); // Strings are identical. - return NIL; - } - if (j == end2) { - // Reached end of string2. - return Fixnum.getInstance(i); - } - char c1 = array1[i]; - char c2 = array2[j]; - if (c1 == c2) { - ++i; - ++j; - continue; - } - if (c1 < c2) - return NIL; - // c1 > c2 - return Fixnum.getInstance(i); + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) { + // note the swap of the strings and lengths here.. + StringIndicesAndChars indicesAndChars = + stringIndicesAndChars(second, first, + fifth, sixth, + third, fourth); + int tmp = lessThanOrEqual(indicesAndChars); + if (tmp < 0) { + return NIL; } + int delta = tmp - indicesAndChars.start1; + int retVal = indicesAndChars.start2 + delta; + return Fixnum.getInstance(retVal); } }; @@ -419,27 +364,22 @@ public LispObject execute(LispObject[] args) { if (args.length != 6) return error(new WrongNumberOfArgumentsException(this)); - char[] array1 = args[0].STRING().getStringChars(); - char[] array2 = args[1].STRING().getStringChars(); - int start1 = Fixnum.getValue(args[2]); - int end1 = Fixnum.getValue(args[3]); - int start2 = Fixnum.getValue(args[4]); - int end2 = Fixnum.getValue(args[5]); - int i = start1; - int j = start2; + StringIndicesAndChars indicesAndChars = stringIndicesAndChars(args); + int i = indicesAndChars.start1; + int j = indicesAndChars.start2; while (true) { - if (i == end1) { + if (i == indicesAndChars.end1) { // Reached end of string1. - if (j == end2) + if (j == indicesAndChars.end2) return NIL; // Strings are identical. return Fixnum.getInstance(i); } - if (j == end2) { + if (j == indicesAndChars.end2) { // Reached end of string2. return NIL; } - char c1 = LispCharacter.toUpperCase(array1[i]); - char c2 = LispCharacter.toUpperCase(array2[j]); + char c1 = LispCharacter.toUpperCase(indicesAndChars.array1[i]); + char c2 = LispCharacter.toUpperCase(indicesAndChars.array2[j]); if (c1 == c2) { ++i; ++j; @@ -465,25 +405,20 @@ public LispObject execute(LispObject[] args) { if (args.length != 6) return error(new WrongNumberOfArgumentsException(this)); - char[] array1 = args[0].STRING().getStringChars(); - char[] array2 = args[1].STRING().getStringChars(); - int start1 = Fixnum.getValue(args[2]); - int end1 = Fixnum.getValue(args[3]); - int start2 = Fixnum.getValue(args[4]); - int end2 = Fixnum.getValue(args[5]); - int i = start1; - int j = start2; + StringIndicesAndChars indicesAndChars = stringIndicesAndChars(args); + int i = indicesAndChars.start1; + int j = indicesAndChars.start2; while (true) { - if (i == end1) { + if (i == indicesAndChars.end1) { // Reached end of string1. return NIL; } - if (j == end2) { + if (j == indicesAndChars.end2) { // Reached end of string2. return Fixnum.getInstance(i); } - char c1 = LispCharacter.toUpperCase(array1[i]); - char c2 = LispCharacter.toUpperCase(array2[j]); + char c1 = LispCharacter.toUpperCase(indicesAndChars.array1[i]); + char c2 = LispCharacter.toUpperCase(indicesAndChars.array2[j]); if (c1 == c2) { ++i; ++j; @@ -509,27 +444,22 @@ public LispObject execute(LispObject[] args) { if (args.length != 6) return error(new WrongNumberOfArgumentsException(this)); - char[] array1 = args[0].STRING().getStringChars(); - char[] array2 = args[1].STRING().getStringChars(); - int start1 = Fixnum.getValue(args[2]); - int end1 = Fixnum.getValue(args[3]); - int start2 = Fixnum.getValue(args[4]); - int end2 = Fixnum.getValue(args[5]); - int i = start1; - int j = start2; + StringIndicesAndChars indicesAndChars = stringIndicesAndChars(args); + int i = indicesAndChars.start1; + int j = indicesAndChars.start2; while (true) { - if (i == end1) { + if (i == indicesAndChars.end1) { // Reached end of string1. - if (j == end2) + if (j == indicesAndChars.end2) return Fixnum.getInstance(i); // Strings are identical. return NIL; } - if (j == end2) { + if (j == indicesAndChars.end2) { // Reached end of string2. return Fixnum.getInstance(i); } - char c1 = LispCharacter.toUpperCase(array1[i]); - char c2 = LispCharacter.toUpperCase(array2[j]); + char c1 = LispCharacter.toUpperCase(indicesAndChars.array1[i]); + char c2 = LispCharacter.toUpperCase(indicesAndChars.array2[j]); if (c1 == c2) { ++i; ++j; @@ -555,25 +485,20 @@ public LispObject execute(LispObject[] args) { if (args.length != 6) return error(new WrongNumberOfArgumentsException(this)); - char[] array1 = args[0].STRING().getStringChars(); - char[] array2 = args[1].STRING().getStringChars(); - int start1 = Fixnum.getValue(args[2]); - int end1 = Fixnum.getValue(args[3]); - int start2 = Fixnum.getValue(args[4]); - int end2 = Fixnum.getValue(args[5]); - int i = start1; - int j = start2; + StringIndicesAndChars indicesAndChars = stringIndicesAndChars(args); + int i = indicesAndChars.start1; + int j = indicesAndChars.start2; while (true) { - if (i == end1) { + if (i == indicesAndChars.end1) { // Reached end of string1. return Fixnum.getInstance(i); } - if (j == end2) { + if (j == indicesAndChars.end2) { // Reached end of string2. return NIL; } - char c1 = LispCharacter.toUpperCase(array1[i]); - char c2 = LispCharacter.toUpperCase(array2[j]); + char c1 = LispCharacter.toUpperCase(indicesAndChars.array1[i]); + char c2 = LispCharacter.toUpperCase(indicesAndChars.array2[j]); if (c1 == c2) { ++i; ++j; From vvoutilainen at common-lisp.net Sat Feb 20 20:17:24 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sat, 20 Feb 2010 15:17:24 -0500 Subject: [armedbear-cvs] r12489 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sat Feb 20 15:17:20 2010 New Revision: 12489 Log: 1) implement string-greaterp in terms of string-lessp 2) implement string-not-greaterp in terms of string-not-lessp Modified: trunk/abcl/src/org/armedbear/lisp/StringFunctions.java Modified: trunk/abcl/src/org/armedbear/lisp/StringFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StringFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StringFunctions.java Sat Feb 20 15:17:20 2010 @@ -2,6 +2,7 @@ * StringFunctions.java * * Copyright (C) 2003-2005 Peter Graves + * Copyright (C) 2010 Ville Voutilainen * $Id$ * * This program is free software; you can redistribute it and/or @@ -206,8 +207,6 @@ } }; - // ### %string< - // Case sensitive. private static int lessThan(StringIndicesAndChars indicesAndChars) { int i = indicesAndChars.start1; int j = indicesAndChars.start2; @@ -235,6 +234,9 @@ return -1; } } + + // ### %string< + // Case sensitive. private static final Primitive _STRING_LESS_THAN = new pf__string_less_than(); private static final class pf__string_less_than extends Primitive { pf__string_less_than() { @@ -279,6 +281,7 @@ return Fixnum.getInstance(retVal); } }; + private static int lessThanOrEqual(StringIndicesAndChars indicesAndChars) { int i = indicesAndChars.start1; int j = indicesAndChars.start2; @@ -352,6 +355,33 @@ } }; + private static int stringLessp(StringIndicesAndChars indicesAndChars) { + int i = indicesAndChars.start1; + int j = indicesAndChars.start2; + while (true) { + if (i == indicesAndChars.end1) { + // Reached end of string1. + if (j == indicesAndChars.end2) + return -1; // Strings are identical. + return i; + } + if (j == indicesAndChars.end2) { + // Reached end of string2. + return -1; + } + char c1 = LispCharacter.toUpperCase(indicesAndChars.array1[i]); + char c2 = LispCharacter.toUpperCase(indicesAndChars.array2[j]); + if (c1 == c2) { + ++i; + ++j; + continue; + } + if (c1 > c2) + return -1; + // c1 < c2 + return i; + } + } // ### %string-lessp // Case insensitive. private static final Primitive _STRING_LESSP = new pf__string_lessp(); @@ -361,35 +391,14 @@ } @Override - public LispObject execute(LispObject[] args) { - if (args.length != 6) - return error(new WrongNumberOfArgumentsException(this)); - StringIndicesAndChars indicesAndChars = stringIndicesAndChars(args); - int i = indicesAndChars.start1; - int j = indicesAndChars.start2; - while (true) { - if (i == indicesAndChars.end1) { - // Reached end of string1. - if (j == indicesAndChars.end2) - return NIL; // Strings are identical. - return Fixnum.getInstance(i); - } - if (j == indicesAndChars.end2) { - // Reached end of string2. - return NIL; - } - char c1 = LispCharacter.toUpperCase(indicesAndChars.array1[i]); - char c2 = LispCharacter.toUpperCase(indicesAndChars.array2[j]); - if (c1 == c2) { - ++i; - ++j; - continue; - } - if (c1 > c2) - return NIL; - // c1 < c2 - return Fixnum.getInstance(i); - } + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) { + StringIndicesAndChars indicesAndChars = + stringIndicesAndChars(first, second, third, + fourth, fifth, sixth); + int retVal = stringLessp(indicesAndChars); + return (retVal >= 0) ? Fixnum.getInstance(retVal) : NIL; } }; @@ -402,36 +411,52 @@ } @Override - public LispObject execute(LispObject[] args) { - if (args.length != 6) - return error(new WrongNumberOfArgumentsException(this)); - StringIndicesAndChars indicesAndChars = stringIndicesAndChars(args); - int i = indicesAndChars.start1; - int j = indicesAndChars.start2; - while (true) { - if (i == indicesAndChars.end1) { - // Reached end of string1. - return NIL; - } - if (j == indicesAndChars.end2) { - // Reached end of string2. - return Fixnum.getInstance(i); - } - char c1 = LispCharacter.toUpperCase(indicesAndChars.array1[i]); - char c2 = LispCharacter.toUpperCase(indicesAndChars.array2[j]); - if (c1 == c2) { - ++i; - ++j; - continue; - } - if (c1 < c2) - return NIL; - // c1 > c2 - return Fixnum.getInstance(i); + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) { + // note the swap of the strings and lengths here.. + StringIndicesAndChars indicesAndChars = + stringIndicesAndChars(second, first, + fifth, sixth, + third, fourth); + int tmp = stringLessp(indicesAndChars); + if (tmp < 0) { + return NIL; } + int delta = tmp - indicesAndChars.start1; + int retVal = indicesAndChars.start2 + delta; + return Fixnum.getInstance(retVal); } }; + private static int stringNotLessp(StringIndicesAndChars indicesAndChars) { + int i = indicesAndChars.start1; + int j = indicesAndChars.start2; + while (true) { + if (i == indicesAndChars.end1) { + // Reached end of string1. + if (j == indicesAndChars.end2) + return i; // Strings are identical. + return -1; + } + if (j == indicesAndChars.end2) { + // Reached end of string2. + return i; + } + char c1 = LispCharacter.toUpperCase(indicesAndChars.array1[i]); + char c2 = LispCharacter.toUpperCase(indicesAndChars.array2[j]); + if (c1 == c2) { + ++i; + ++j; + continue; + } + if (c1 > c2) + return i; + // c1 < c2 + return -1; + } + } + // ### %string-not-lessp // Case insensitive. private static final Primitive _STRING_NOT_LESSP = new pf__string_not_lessp(); @@ -441,35 +466,14 @@ } @Override - public LispObject execute(LispObject[] args) { - if (args.length != 6) - return error(new WrongNumberOfArgumentsException(this)); - StringIndicesAndChars indicesAndChars = stringIndicesAndChars(args); - int i = indicesAndChars.start1; - int j = indicesAndChars.start2; - while (true) { - if (i == indicesAndChars.end1) { - // Reached end of string1. - if (j == indicesAndChars.end2) - return Fixnum.getInstance(i); // Strings are identical. - return NIL; - } - if (j == indicesAndChars.end2) { - // Reached end of string2. - return Fixnum.getInstance(i); - } - char c1 = LispCharacter.toUpperCase(indicesAndChars.array1[i]); - char c2 = LispCharacter.toUpperCase(indicesAndChars.array2[j]); - if (c1 == c2) { - ++i; - ++j; - continue; - } - if (c1 > c2) - return Fixnum.getInstance(i); - // c1 < c2 - return NIL; - } + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) { + StringIndicesAndChars indicesAndChars = + stringIndicesAndChars(first, second, third, + fourth, fifth, sixth); + int retVal = stringNotLessp(indicesAndChars); + return (retVal >= 0) ? Fixnum.getInstance(retVal) : NIL; } }; @@ -482,33 +486,21 @@ } @Override - public LispObject execute(LispObject[] args) { - if (args.length != 6) - return error(new WrongNumberOfArgumentsException(this)); - StringIndicesAndChars indicesAndChars = stringIndicesAndChars(args); - int i = indicesAndChars.start1; - int j = indicesAndChars.start2; - while (true) { - if (i == indicesAndChars.end1) { - // Reached end of string1. - return Fixnum.getInstance(i); - } - if (j == indicesAndChars.end2) { - // Reached end of string2. - return NIL; - } - char c1 = LispCharacter.toUpperCase(indicesAndChars.array1[i]); - char c2 = LispCharacter.toUpperCase(indicesAndChars.array2[j]); - if (c1 == c2) { - ++i; - ++j; - continue; - } - if (c1 > c2) - return NIL; - // c1 < c2 - return Fixnum.getInstance(i); + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) { + // note the swap of the strings and lengths here.. + StringIndicesAndChars indicesAndChars = + stringIndicesAndChars(second, first, + fifth, sixth, + third, fourth); + int tmp = stringNotLessp(indicesAndChars); + if (tmp < 0) { + return NIL; } + int delta = tmp - indicesAndChars.start1; + int retVal = indicesAndChars.start2 + delta; + return Fixnum.getInstance(retVal); } }; From vvoutilainen at common-lisp.net Sat Feb 20 20:36:41 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sat, 20 Feb 2010 15:36:41 -0500 Subject: [armedbear-cvs] r12490 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sat Feb 20 15:36:40 2010 New Revision: 12490 Log: More cleanups, introduce a function for adjusting return values when a function is implemented in terms of another. Modified: trunk/abcl/src/org/armedbear/lisp/StringFunctions.java Modified: trunk/abcl/src/org/armedbear/lisp/StringFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StringFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StringFunctions.java Sat Feb 20 15:36:40 2010 @@ -255,6 +255,17 @@ } }; + private static LispObject + swapReturnValue(int original, + StringIndicesAndChars indicesAndChars) { + if (original < 0) { + return NIL; + } + int delta = original - indicesAndChars.start1; + int retVal = indicesAndChars.start2 + delta; + return Fixnum.getInstance(retVal); + } + // ### %string> // Case sensitive. private static final Primitive _STRING_GREATER_THAN = new pf__string_greater_than(); @@ -273,12 +284,7 @@ fifth, sixth, third, fourth); int tmp = lessThan(indicesAndChars); - if (tmp < 0) { - return NIL; - } - int delta = tmp - indicesAndChars.start1; - int retVal = indicesAndChars.start2 + delta; - return Fixnum.getInstance(retVal); + return swapReturnValue(tmp, indicesAndChars); } }; @@ -346,12 +352,7 @@ fifth, sixth, third, fourth); int tmp = lessThanOrEqual(indicesAndChars); - if (tmp < 0) { - return NIL; - } - int delta = tmp - indicesAndChars.start1; - int retVal = indicesAndChars.start2 + delta; - return Fixnum.getInstance(retVal); + return swapReturnValue(tmp, indicesAndChars); } }; @@ -420,12 +421,7 @@ fifth, sixth, third, fourth); int tmp = stringLessp(indicesAndChars); - if (tmp < 0) { - return NIL; - } - int delta = tmp - indicesAndChars.start1; - int retVal = indicesAndChars.start2 + delta; - return Fixnum.getInstance(retVal); + return swapReturnValue(tmp, indicesAndChars); } }; @@ -495,12 +491,7 @@ fifth, sixth, third, fourth); int tmp = stringNotLessp(indicesAndChars); - if (tmp < 0) { - return NIL; - } - int delta = tmp - indicesAndChars.start1; - int retVal = indicesAndChars.start2 + delta; - return Fixnum.getInstance(retVal); + return swapReturnValue(tmp, indicesAndChars); } }; From mevenson at common-lisp.net Sat Feb 20 23:52:31 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 20 Feb 2010 18:52:31 -0500 Subject: [armedbear-cvs] r12491 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat Feb 20 18:52:28 2010 New Revision: 12491 Log: DIRECTORY works for (some) jar:file cases. Doesn't handle JAR in JAR or JAR not file:. 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 Feb 20 18:52:28 2010 @@ -71,25 +71,53 @@ (let ((pathname (merge-pathnames pathspec))) (when (logical-pathname-p pathname) (setq pathname (translate-logical-pathname pathname))) - (if (or (position #\* (namestring pathname)) - (wild-pathname-p pathname)) - (let ((namestring (directory-namestring pathname))) - (when (and namestring (> (length namestring) 0)) - #+windows - (let ((device (pathname-device pathname))) - (when device - (setq namestring (concatenate 'string device ":" namestring)))) - (let ((entries (list-directories-with-wildcards namestring)) - (matching-entries ())) - (dolist (entry entries) - (cond ((file-directory-p entry) - (when (pathname-match-p (file-namestring (pathname-as-file entry)) (file-namestring pathname)) - (push entry matching-entries))) - ((pathname-match-p (file-namestring entry) (file-namestring pathname)) - (push entry matching-entries)))) - matching-entries))) - ;; Not wild. - (let ((truename (probe-file pathname))) - (if truename - (list (pathname truename)) + (if (pathname-jar-p pathname) + (directory-jar pathspec) + (if (or (position #\* (namestring pathname)) + (wild-pathname-p pathname)) + (let ((namestring (directory-namestring pathname))) + (when (and namestring (> (length namestring) 0)) + #+windows + (let ((device (pathname-device pathname))) + (when device + (setq namestring (concatenate 'string device ":" namestring)))) + (let ((entries (list-directories-with-wildcards namestring)) + (matching-entries ())) + (dolist (entry entries) + (cond ((file-directory-p entry) + (when (pathname-match-p (file-namestring (pathname-as-file entry)) (file-namestring pathname)) + (push entry matching-entries))) + ((pathname-match-p (file-namestring entry) (file-namestring pathname)) + (push entry matching-entries)))) + matching-entries))) + ;; Not wild. + (let ((truename (probe-file pathname))) + (if truename + (list (pathname truename)) + nil)))))) + +;;; Thanks to Alan "Never touch Java unless you have to" Ruttenberg +;;; XXX need to handle JAR in JAR cases +;;; XXX doesn't handle non file: JAR entries +(defun directory-jar (pathname) + (let* ((device (pathname-device pathname)) + (jarfile (namestring (car device))) + (rest-pathname (namestring (make-pathname :directory `(:absolute ,@(cdr (pathname-directory pathname))) + :name (pathname-name pathname) + :type (pathname-type pathname))))) + (if (or (position #\* (namestring rest-pathname)) + (wild-pathname-p rest-pathname)) + (let ((jar (java:jnew "java.util.zip.ZipFile" jarfile))) + (let ((els (java:jcall "entries" jar))) + (loop :while (java:jcall "hasMoreElements" els) + :for name = (java:jcall "getName" + (java:jcall "nextElement" els)) + :when (pathname-match-p (concatenate 'string "/" name) rest-pathname) + :collect (make-pathname :device (pathname-device pathname) + :name (pathname-name name) + :type (pathname-type name) + :directory `(:relative ,@(cdr (pathname-directory name))))))) + (let ((truename (probe-file pathname))) + (if truename + (list truename) nil))))) From mevenson at common-lisp.net Sun Feb 21 07:34:23 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 21 Feb 2010 02:34:23 -0500 Subject: [armedbear-cvs] r12492 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun Feb 21 02:34:21 2010 New Revision: 12492 Log: Revert r12490. ABCL system Lisp should not break the abstraction barrier by utlizing the Java FFI, but should *only* use primitives/special operators. If we (developers) don't accept such patches, we shouldn't be checking them in. 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 Sun Feb 21 02:34:21 2010 @@ -71,53 +71,25 @@ (let ((pathname (merge-pathnames pathspec))) (when (logical-pathname-p pathname) (setq pathname (translate-logical-pathname pathname))) - (if (pathname-jar-p pathname) - (directory-jar pathspec) - (if (or (position #\* (namestring pathname)) - (wild-pathname-p pathname)) - (let ((namestring (directory-namestring pathname))) - (when (and namestring (> (length namestring) 0)) - #+windows - (let ((device (pathname-device pathname))) - (when device - (setq namestring (concatenate 'string device ":" namestring)))) - (let ((entries (list-directories-with-wildcards namestring)) - (matching-entries ())) - (dolist (entry entries) - (cond ((file-directory-p entry) - (when (pathname-match-p (file-namestring (pathname-as-file entry)) (file-namestring pathname)) - (push entry matching-entries))) - ((pathname-match-p (file-namestring entry) (file-namestring pathname)) - (push entry matching-entries)))) - matching-entries))) - ;; Not wild. - (let ((truename (probe-file pathname))) - (if truename - (list (pathname truename)) - nil)))))) - -;;; Thanks to Alan "Never touch Java unless you have to" Ruttenberg -;;; XXX need to handle JAR in JAR cases -;;; XXX doesn't handle non file: JAR entries -(defun directory-jar (pathname) - (let* ((device (pathname-device pathname)) - (jarfile (namestring (car device))) - (rest-pathname (namestring (make-pathname :directory `(:absolute ,@(cdr (pathname-directory pathname))) - :name (pathname-name pathname) - :type (pathname-type pathname))))) - (if (or (position #\* (namestring rest-pathname)) - (wild-pathname-p rest-pathname)) - (let ((jar (java:jnew "java.util.zip.ZipFile" jarfile))) - (let ((els (java:jcall "entries" jar))) - (loop :while (java:jcall "hasMoreElements" els) - :for name = (java:jcall "getName" - (java:jcall "nextElement" els)) - :when (pathname-match-p (concatenate 'string "/" name) rest-pathname) - :collect (make-pathname :device (pathname-device pathname) - :name (pathname-name name) - :type (pathname-type name) - :directory `(:relative ,@(cdr (pathname-directory name))))))) - (let ((truename (probe-file pathname))) - (if truename - (list truename) + (if (or (position #\* (namestring pathname)) + (wild-pathname-p pathname)) + (let ((namestring (directory-namestring pathname))) + (when (and namestring (> (length namestring) 0)) + #+windows + (let ((device (pathname-device pathname))) + (when device + (setq namestring (concatenate 'string device ":" namestring)))) + (let ((entries (list-directories-with-wildcards namestring)) + (matching-entries ())) + (dolist (entry entries) + (cond ((file-directory-p entry) + (when (pathname-match-p (file-namestring (pathname-as-file entry)) (file-namestring pathname)) + (push entry matching-entries))) + ((pathname-match-p (file-namestring entry) (file-namestring pathname)) + (push entry matching-entries)))) + matching-entries))) + ;; Not wild. + (let ((truename (probe-file pathname))) + (if truename + (list (pathname truename)) nil))))) From vvoutilainen at common-lisp.net Sun Feb 21 13:53:47 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 21 Feb 2010 08:53:47 -0500 Subject: [armedbear-cvs] r12493 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Feb 21 08:53:44 2010 New Revision: 12493 Log: 1) do the param checking for all functions 2) with the consolidated param checking, clean up string/nstring-upcase/downcase/capitalize Modified: trunk/abcl/src/org/armedbear/lisp/StringFunctions.java Modified: trunk/abcl/src/org/armedbear/lisp/StringFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StringFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StringFunctions.java Sun Feb 21 08:53:44 2010 @@ -38,38 +38,101 @@ import java.util.Arrays; public final class StringFunctions { private final static class StringIndicesAndChars { - + AbstractString string1; public char[] array1; public char[] array2; public int start1 = 0; - public int end1; + public int end1 = 0; public int start2 = 0; - public int end2; + public int end2 = 0; }; + private final static void + checkParams(StringIndicesAndChars indicesAndChars) { + if (indicesAndChars.start1 < 0 + || indicesAndChars.start1 > indicesAndChars.array1.length) + error(new TypeError("Invalid start position " + + indicesAndChars.start1 + ".")); + if (indicesAndChars.end1 < 0 + || indicesAndChars.end1 > indicesAndChars.array1.length) + error(new TypeError("Invalid end position " + + indicesAndChars.end1 + ".")); + + if (indicesAndChars.start1 > indicesAndChars.end1) + error(new TypeError("Start (" + + indicesAndChars.start1 + + ") is greater than end (" + + indicesAndChars.end1 + ").")); + if (indicesAndChars.array2 != null) { + if (indicesAndChars.start2 < 0 + || indicesAndChars.start2 > indicesAndChars.array2.length) + error(new TypeError("Invalid start2 position " + + indicesAndChars.start2 + ".")); + if (indicesAndChars.end2 < 0 + || indicesAndChars.end2 > indicesAndChars.array2.length) + error(new TypeError("Invalid end2 position " + + indicesAndChars.end2 + ".")); + if (indicesAndChars.start2 > indicesAndChars.end2) + error(new TypeError("Start2 (" + + indicesAndChars.start2 + + ") is greater than end2 (" + + indicesAndChars.end2 + ").")); + } + + } + private final static StringIndicesAndChars stringIndicesAndChars(LispObject... params) { StringIndicesAndChars retVal = new StringIndicesAndChars(); - retVal.array1 = params[0].STRING().getStringChars(); - retVal.array2 = params[1].STRING().getStringChars(); + retVal.string1 = checkString(params[0].STRING()); + retVal.array1 = retVal.string1.getStringChars(); retVal.end1 = retVal.array1.length; - retVal.end2 = retVal.array2.length; - if (params.length > 2) { - if (params[2] != NIL) { - retVal.start1 = Fixnum.getValue(params[2]); + if (params.length == 3) { + if (params[1] != NIL) { + retVal.start1 = Fixnum.getValue(params[1]); } - if (params[3] != NIL) { - retVal.end1 = Fixnum.getValue(params[3]); - } - if (params[4] != NIL) { - retVal.start2 = Fixnum.getValue(params[4]); + if (params[2] != NIL) { + retVal.end1 = Fixnum.getValue(params[2]); } - if (params[5] != NIL) { - retVal.end2 = Fixnum.getValue(params[5]); + } else { + retVal.array2 = params[1].STRING().getStringChars(); + retVal.end2 = retVal.array2.length; + if (params.length > 2) { + if (params[2] != NIL) { + retVal.start1 = Fixnum.getValue(params[2]); + } + if (params[3] != NIL) { + retVal.end1 = Fixnum.getValue(params[3]); + } + if (params[4] != NIL) { + retVal.start2 = Fixnum.getValue(params[4]); + } + if (params[5] != NIL) { + retVal.end2 = Fixnum.getValue(params[5]); + } } } + checkParams(retVal); return retVal; } + // ### %%string= + // Case sensitive. + private static final Primitive __STRING_EQUAL = new pf___string_equal(); + private static final class pf___string_equal extends Primitive { + pf___string_equal() { + super("%%string=", PACKAGE_SYS, false); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + + { + StringIndicesAndChars chars = stringIndicesAndChars(first, second); + return Arrays.equals(chars.array1, chars.array2) ? + T : NIL; + }; + } + // ### %string= // Case sensitive. private static final Primitive _STRING_EQUAL = new pf__string_equal(); @@ -91,23 +154,6 @@ } }; - // ### %%string= - // Case sensitive. - private static final Primitive __STRING_EQUAL = new pf___string_equal(); - private static final class pf___string_equal extends Primitive { - pf___string_equal() { - super("%%string=", PACKAGE_SYS, false); - } - - @Override - public LispObject execute(LispObject first, LispObject second) - - { - StringIndicesAndChars chars = stringIndicesAndChars(first, second); - return Arrays.equals(chars.array1, chars.array2) ? - T : NIL; - }; - } // ### %string/= // Case sensitive. @@ -507,29 +553,17 @@ LispObject third) { - LispObject s = first.STRING(); - final int length = s.length(); - int start = (int) Fixnum.getValue(second); - if (start < 0 || start > length) - return error(new TypeError("Invalid start position " + start + ".")); - int end; - if (third == NIL) - end = length; - else - end = (int) Fixnum.getValue(third); - if (end < 0 || end > length) - return error(new TypeError("Invalid end position " + start + ".")); - if (start > end) - return error(new TypeError("Start (" + start + ") is greater than end (" + end + ").")); - StringBuilder sb = new StringBuilder(length); - char[] array = s.getStringChars(); + StringIndicesAndChars indicesAndChars = + stringIndicesAndChars(first, second, third); + StringBuilder sb = new StringBuilder(indicesAndChars.array1.length); int i; - for (i = 0; i < start; i++) - sb.append(array[i]); - for (i = start; i < end; i++) - sb.append(LispCharacter.toUpperCase(array[i])); - for (i = end; i < length; i++) - sb.append(array[i]); + for (i = 0; i < indicesAndChars.start1; i++) + sb.append(indicesAndChars.array1[i]); + for (i = indicesAndChars.start1; i < indicesAndChars.end1; i++) + sb.append(LispCharacter.toUpperCase(indicesAndChars.array1[i])); + for (i = indicesAndChars.end1; + i < indicesAndChars.array1.length; i++) + sb.append(indicesAndChars.array1[i]); return new SimpleString(sb); } }; @@ -544,29 +578,17 @@ @Override public LispObject execute(LispObject first, LispObject second, LispObject third) { - LispObject s = first.STRING(); - final int length = s.length(); - int start = (int) Fixnum.getValue(second); - if (start < 0 || start > length) - return error(new TypeError("Invalid start position " + start + ".")); - int end; - if (third == NIL) - end = length; - else - end = (int) Fixnum.getValue(third); - if (end < 0 || end > length) - return error(new TypeError("Invalid end position " + start + ".")); - if (start > end) - return error(new TypeError("Start (" + start + ") is greater than end (" + end + ").")); - StringBuilder sb = new StringBuilder(length); - char[] array = s.getStringChars(); + StringIndicesAndChars indicesAndChars = + stringIndicesAndChars(first, second, third); + StringBuilder sb = new StringBuilder(indicesAndChars.array1.length); int i; - for (i = 0; i < start; i++) - sb.append(array[i]); - for (i = start; i < end; i++) - sb.append(LispCharacter.toLowerCase(array[i])); - for (i = end; i < length; i++) - sb.append(array[i]); + for (i = 0; i < indicesAndChars.start1; i++) + sb.append(indicesAndChars.array1[i]); + for (i = indicesAndChars.start1; i < indicesAndChars.end1; i++) + sb.append(LispCharacter.toLowerCase(indicesAndChars.array1[i])); + for (i = indicesAndChars.end1; + i < indicesAndChars.array1.length; i++) + sb.append(indicesAndChars.array1[i]); return new SimpleString(sb); } }; @@ -583,28 +605,15 @@ LispObject third) { - LispObject s = first.STRING(); - final int length = s.length(); - int start = (int) Fixnum.getValue(second); - if (start < 0 || start > length) - return error(new TypeError("Invalid start position " + start + ".")); - int end; - if (third == NIL) - end = length; - else - end = (int) Fixnum.getValue(third); - if (end < 0 || end > length) - return error(new TypeError("Invalid end position " + start + ".")); - if (start > end) - return error(new TypeError("Start (" + start + ") is greater than end (" + end + ").")); - StringBuilder sb = new StringBuilder(length); - char[] array = s.getStringChars(); + StringIndicesAndChars indicesAndChars = + stringIndicesAndChars(first, second, third); + StringBuilder sb = new StringBuilder(indicesAndChars.array1.length); boolean lastCharWasAlphanumeric = false; int i; - for (i = 0; i < start; i++) - sb.append(array[i]); - for (i = start; i < end; i++) { - char c = array[i]; + for (i = 0; i < indicesAndChars.start1; i++) + sb.append(indicesAndChars.array1[i]); + for (i = indicesAndChars.start1; i < indicesAndChars.end1; i++) { + char c = indicesAndChars.array1[i]; if (Character.isLowerCase(c)) { sb.append(lastCharWasAlphanumeric ? c : LispCharacter.toUpperCase(c)); lastCharWasAlphanumeric = true; @@ -616,8 +625,9 @@ lastCharWasAlphanumeric = Character.isDigit(c); } } - for (i = end; i < length; i++) - sb.append(array[i]); + for (i = indicesAndChars.end1; + i < indicesAndChars.array1.length; i++) + sb.append(indicesAndChars.array1[i]); return new SimpleString(sb); } }; @@ -634,22 +644,12 @@ LispObject third) { - final AbstractString string = checkString(first); - final int length = string.length(); - int start = (int) Fixnum.getValue(second); - if (start < 0 || start > length) - return error(new TypeError("Invalid start position " + start + ".")); - int end; - if (third == NIL) - end = length; - else - end = (int) Fixnum.getValue(third); - if (end < 0 || end > length) - return error(new TypeError("Invalid end position " + start + ".")); - if (start > end) - return error(new TypeError("Start (" + start + ") is greater than end (" + end + ").")); - for (int i = start; i < end; i++) - string.setCharAt(i, LispCharacter.toUpperCase(string.charAt(i))); + StringIndicesAndChars indicesAndChars = + stringIndicesAndChars(first, second, third); + AbstractString string = indicesAndChars.string1; + for (int i = indicesAndChars.start1; i < indicesAndChars.end1; i++) + string.setCharAt(i, + LispCharacter.toUpperCase(string.charAt(i))); return string; } }; @@ -666,22 +666,12 @@ LispObject third) { - final AbstractString string = checkString(first); - final int length = string.length(); - int start = (int) Fixnum.getValue(second); - if (start < 0 || start > length) - return error(new TypeError("Invalid start position " + start + ".")); - int end; - if (third == NIL) - end = length; - else - end = (int) Fixnum.getValue(third); - if (end < 0 || end > length) - return error(new TypeError("Invalid end position " + start + ".")); - if (start > end) - return error(new TypeError("Start (" + start + ") is greater than end (" + end + ").")); - for (int i = start; i < end; i++) - string.setCharAt(i, LispCharacter.toLowerCase(string.charAt(i))); + StringIndicesAndChars indicesAndChars = + stringIndicesAndChars(first, second, third); + AbstractString string = indicesAndChars.string1; + for (int i = indicesAndChars.start1; i < indicesAndChars.end1; i++) + string.setCharAt(i, + LispCharacter.toLowerCase(string.charAt(i))); return string; } }; @@ -698,30 +688,22 @@ LispObject third) { - AbstractString string = checkString(first); - final int length = string.length(); - int start = (int) Fixnum.getValue(second); - if (start < 0 || start > length) - return error(new TypeError("Invalid start position " + start + ".")); - int end; - if (third == NIL) - end = length; - else - end = (int) Fixnum.getValue(third); - if (end < 0 || end > length) - return error(new TypeError("Invalid end position " + start + ".")); - if (start > end) - return error(new TypeError("Start (" + start + ") is greater than end (" + end + ").")); + StringIndicesAndChars indicesAndChars = + stringIndicesAndChars(first, second, third); boolean lastCharWasAlphanumeric = false; - for (int i = start; i < end; i++) { + AbstractString string = indicesAndChars.string1; + for (int i = indicesAndChars.start1; + i < indicesAndChars.end1; i++) { char c = string.charAt(i); if (Character.isLowerCase(c)) { if (!lastCharWasAlphanumeric) - string.setCharAt(i, LispCharacter.toUpperCase(c)); + string.setCharAt(i, + LispCharacter.toUpperCase(c)); lastCharWasAlphanumeric = true; } else if (Character.isUpperCase(c)) { if (lastCharWasAlphanumeric) - string.setCharAt(i, LispCharacter.toLowerCase(c)); + string.setCharAt(i, + LispCharacter.toLowerCase(c)); lastCharWasAlphanumeric = true; } else lastCharWasAlphanumeric = Character.isDigit(c); From vvoutilainen at common-lisp.net Sun Feb 21 14:33:14 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 21 Feb 2010 09:33:14 -0500 Subject: [armedbear-cvs] r12494 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Feb 21 09:33:12 2010 New Revision: 12494 Log: Don't use StringBuilder for StringFunctions that can use arraycopy instead. This requires making the relevant SimpleString constructor public. Modified: trunk/abcl/src/org/armedbear/lisp/SimpleString.java trunk/abcl/src/org/armedbear/lisp/StringFunctions.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 Sun Feb 21 09:33:12 2010 @@ -78,7 +78,7 @@ capacity = chars.length; } - private SimpleString(char[] chars) + public SimpleString(char[] chars) { this.chars = chars; capacity = chars.length; Modified: trunk/abcl/src/org/armedbear/lisp/StringFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StringFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StringFunctions.java Sun Feb 21 09:33:12 2010 @@ -555,16 +555,17 @@ { StringIndicesAndChars indicesAndChars = stringIndicesAndChars(first, second, third); - StringBuilder sb = new StringBuilder(indicesAndChars.array1.length); - int i; - for (i = 0; i < indicesAndChars.start1; i++) - sb.append(indicesAndChars.array1[i]); - for (i = indicesAndChars.start1; i < indicesAndChars.end1; i++) - sb.append(LispCharacter.toUpperCase(indicesAndChars.array1[i])); - for (i = indicesAndChars.end1; - i < indicesAndChars.array1.length; i++) - sb.append(indicesAndChars.array1[i]); - return new SimpleString(sb); + char[] array = new char[indicesAndChars.array1.length]; + System.arraycopy(indicesAndChars.array1, 0, + array, 0, + indicesAndChars.start1); + for (int i = indicesAndChars.start1; i < indicesAndChars.end1; i++) + array[i] = LispCharacter.toUpperCase(indicesAndChars.array1[i]); + System.arraycopy(indicesAndChars.array1, indicesAndChars.end1, + array, indicesAndChars.end1, + indicesAndChars.array1.length + - indicesAndChars.end1); + return new SimpleString(array); } }; @@ -580,16 +581,17 @@ LispObject third) { StringIndicesAndChars indicesAndChars = stringIndicesAndChars(first, second, third); - StringBuilder sb = new StringBuilder(indicesAndChars.array1.length); - int i; - for (i = 0; i < indicesAndChars.start1; i++) - sb.append(indicesAndChars.array1[i]); - for (i = indicesAndChars.start1; i < indicesAndChars.end1; i++) - sb.append(LispCharacter.toLowerCase(indicesAndChars.array1[i])); - for (i = indicesAndChars.end1; - i < indicesAndChars.array1.length; i++) - sb.append(indicesAndChars.array1[i]); - return new SimpleString(sb); + char[] array = new char[indicesAndChars.array1.length]; + System.arraycopy(indicesAndChars.array1, 0, + array, 0, + indicesAndChars.start1); + for (int i = indicesAndChars.start1; i < indicesAndChars.end1; i++) + array[i] = LispCharacter.toLowerCase(indicesAndChars.array1[i]); + System.arraycopy(indicesAndChars.array1, indicesAndChars.end1, + array, indicesAndChars.end1, + indicesAndChars.array1.length + - indicesAndChars.end1); + return new SimpleString(array); } }; @@ -607,28 +609,32 @@ { StringIndicesAndChars indicesAndChars = stringIndicesAndChars(first, second, third); - StringBuilder sb = new StringBuilder(indicesAndChars.array1.length); + char[] array = new char[indicesAndChars.array1.length]; boolean lastCharWasAlphanumeric = false; - int i; - for (i = 0; i < indicesAndChars.start1; i++) - sb.append(indicesAndChars.array1[i]); - for (i = indicesAndChars.start1; i < indicesAndChars.end1; i++) { + System.arraycopy(indicesAndChars.array1, 0, + array, 0, + indicesAndChars.start1); + for (int i = indicesAndChars.start1; + i < indicesAndChars.end1; i++) { char c = indicesAndChars.array1[i]; if (Character.isLowerCase(c)) { - sb.append(lastCharWasAlphanumeric ? c : LispCharacter.toUpperCase(c)); + array[i] = lastCharWasAlphanumeric ? + c : LispCharacter.toUpperCase(c); lastCharWasAlphanumeric = true; } else if (Character.isUpperCase(c)) { - sb.append(lastCharWasAlphanumeric ? LispCharacter.toLowerCase(c) : c); + array[i] = lastCharWasAlphanumeric ? + LispCharacter.toLowerCase(c) : c; lastCharWasAlphanumeric = true; } else { - sb.append(c); + array[i] = c; lastCharWasAlphanumeric = Character.isDigit(c); } } - for (i = indicesAndChars.end1; - i < indicesAndChars.array1.length; i++) - sb.append(indicesAndChars.array1[i]); - return new SimpleString(sb); + System.arraycopy(indicesAndChars.array1, indicesAndChars.end1, + array, indicesAndChars.end1, + indicesAndChars.array1.length + - indicesAndChars.end1); + return new SimpleString(array); } }; From vvoutilainen at common-lisp.net Sun Feb 21 15:22:41 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 21 Feb 2010 10:22:41 -0500 Subject: [armedbear-cvs] r12495 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Feb 21 10:22:39 2010 New Revision: 12495 Log: Use sane names for parameters. Modified: trunk/abcl/src/org/armedbear/lisp/StringFunctions.java Modified: trunk/abcl/src/org/armedbear/lisp/StringFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StringFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StringFunctions.java Sun Feb 21 10:22:39 2010 @@ -124,10 +124,11 @@ } @Override - public LispObject execute(LispObject first, LispObject second) + public LispObject execute(LispObject string1, LispObject string2) { - StringIndicesAndChars chars = stringIndicesAndChars(first, second); + StringIndicesAndChars chars = + stringIndicesAndChars(string1, string2); return Arrays.equals(chars.array1, chars.array2) ? T : NIL; }; @@ -142,14 +143,15 @@ } @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) + public LispObject execute(LispObject string1, LispObject string2, + LispObject start1, LispObject end1, + LispObject start2, LispObject end2) { return - (_STRING_NOT_EQUAL.execute(first, second, third, - fourth, fifth, sixth) + (_STRING_NOT_EQUAL.execute(string1, string2, + start1, end1, + start2, end2) == NIL) ? T : NIL; } }; @@ -164,12 +166,12 @@ } @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) { + public LispObject execute(LispObject string1, LispObject string2, + LispObject start1, LispObject end1, + LispObject start2, LispObject end2) { StringIndicesAndChars indicesAndChars = - stringIndicesAndChars(first, second, third, fourth, - fifth, sixth); + stringIndicesAndChars(string1, string2, start1, end1, + start2, end2); int i = indicesAndChars.start1; int j = indicesAndChars.start2; while (true) { @@ -200,13 +202,14 @@ } @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) + public LispObject execute(LispObject string1, LispObject string2, + LispObject start1, LispObject end1, + LispObject start2, LispObject end2) { - return (_STRING_NOT_EQUAL_IGNORE_CASE.execute(first, second, third, - fourth, fifth, sixth) + return (_STRING_NOT_EQUAL_IGNORE_CASE.execute(string1, string2, + start1, end1, + start2, end2) == NIL) ? T : NIL; } }; @@ -220,12 +223,12 @@ } @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) { + public LispObject execute(LispObject string1, LispObject string2, + LispObject start1, LispObject end1, + LispObject start2, LispObject end2) { StringIndicesAndChars indicesAndChars = - stringIndicesAndChars(first, second, third, fourth, - fifth, sixth); + stringIndicesAndChars(string1, string2, start1, end1, + start2, end2); int i = indicesAndChars.start1; int j = indicesAndChars.start2; while (true) { @@ -290,12 +293,12 @@ } @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) { + public LispObject execute(LispObject string1, LispObject string2, + LispObject start1, LispObject end1, + LispObject start2, LispObject end2) { StringIndicesAndChars indicesAndChars = - stringIndicesAndChars(first, second, third, - fourth, fifth, sixth); + stringIndicesAndChars(string1, string2, + start1, end1, start2, end2); int retVal = lessThan(indicesAndChars); return (retVal >= 0) ? Fixnum.getInstance(retVal) : NIL; } @@ -321,14 +324,14 @@ } @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) { + public LispObject execute(LispObject string1, LispObject string2, + LispObject start1, LispObject end1, + LispObject start2, LispObject end2) { // note the swap of the strings and lengths here.. StringIndicesAndChars indicesAndChars = - stringIndicesAndChars(second, first, - fifth, sixth, - third, fourth); + stringIndicesAndChars(string2, string1, + start2, end2, + start1, end1); int tmp = lessThan(indicesAndChars); return swapReturnValue(tmp, indicesAndChars); } @@ -368,13 +371,13 @@ } @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) { + public LispObject execute(LispObject string1, LispObject string2, + LispObject start1, LispObject end1, + LispObject start2, LispObject end2) { StringIndicesAndChars indicesAndChars = - stringIndicesAndChars(first, second, third, - fourth, fifth, sixth); + stringIndicesAndChars(string1, string2, + start1, end1, start2, end2); int retVal = lessThanOrEqual(indicesAndChars); return (retVal >= 0) ? Fixnum.getInstance(retVal) : NIL; } @@ -389,14 +392,14 @@ } @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) { + public LispObject execute(LispObject string1, LispObject string2, + LispObject start1, LispObject end1, + LispObject start2, LispObject end2) { // note the swap of the strings and lengths here.. StringIndicesAndChars indicesAndChars = - stringIndicesAndChars(second, first, - fifth, sixth, - third, fourth); + stringIndicesAndChars(string2, string1, + start2, end2, + start1, end1); int tmp = lessThanOrEqual(indicesAndChars); return swapReturnValue(tmp, indicesAndChars); } @@ -438,12 +441,12 @@ } @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) { + public LispObject execute(LispObject string1, LispObject string2, + LispObject start1, LispObject end1, + LispObject start2, LispObject end2) { StringIndicesAndChars indicesAndChars = - stringIndicesAndChars(first, second, third, - fourth, fifth, sixth); + stringIndicesAndChars(string1, string2, + start1, end1, start2, end2); int retVal = stringLessp(indicesAndChars); return (retVal >= 0) ? Fixnum.getInstance(retVal) : NIL; } @@ -458,14 +461,14 @@ } @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) { + public LispObject execute(LispObject string1, LispObject string2, + LispObject start1, LispObject end1, + LispObject start2, LispObject end2) { // note the swap of the strings and lengths here.. StringIndicesAndChars indicesAndChars = - stringIndicesAndChars(second, first, - fifth, sixth, - third, fourth); + stringIndicesAndChars(string2, string1, + start2, end2, + start1, end1); int tmp = stringLessp(indicesAndChars); return swapReturnValue(tmp, indicesAndChars); } @@ -508,12 +511,12 @@ } @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) { + public LispObject execute(LispObject string1, LispObject string2, + LispObject start1, LispObject end1, + LispObject start2, LispObject end2) { StringIndicesAndChars indicesAndChars = - stringIndicesAndChars(first, second, third, - fourth, fifth, sixth); + stringIndicesAndChars(string1, string2, + start1, end1, start2, end2); int retVal = stringNotLessp(indicesAndChars); return (retVal >= 0) ? Fixnum.getInstance(retVal) : NIL; } @@ -528,14 +531,14 @@ } @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) { + public LispObject execute(LispObject string1, LispObject string2, + LispObject start1, LispObject end1, + LispObject start2, LispObject end2) { // note the swap of the strings and lengths here.. StringIndicesAndChars indicesAndChars = - stringIndicesAndChars(second, first, - fifth, sixth, - third, fourth); + stringIndicesAndChars(string2, string1, + start2, end2, + start1, end1); int tmp = stringNotLessp(indicesAndChars); return swapReturnValue(tmp, indicesAndChars); } @@ -549,12 +552,12 @@ } @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) + public LispObject execute(LispObject string, LispObject start, + LispObject end) { StringIndicesAndChars indicesAndChars = - stringIndicesAndChars(first, second, third); + stringIndicesAndChars(string, start, end); char[] array = new char[indicesAndChars.array1.length]; System.arraycopy(indicesAndChars.array1, 0, array, 0, @@ -577,10 +580,10 @@ } @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) { + public LispObject execute(LispObject string, LispObject start, + LispObject end) { StringIndicesAndChars indicesAndChars = - stringIndicesAndChars(first, second, third); + stringIndicesAndChars(string, start, end); char[] array = new char[indicesAndChars.array1.length]; System.arraycopy(indicesAndChars.array1, 0, array, 0, @@ -603,12 +606,12 @@ } @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) + public LispObject execute(LispObject string, LispObject start, + LispObject end) { StringIndicesAndChars indicesAndChars = - stringIndicesAndChars(first, second, third); + stringIndicesAndChars(string, start, end); char[] array = new char[indicesAndChars.array1.length]; boolean lastCharWasAlphanumeric = false; System.arraycopy(indicesAndChars.array1, 0, @@ -646,17 +649,19 @@ } @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) + public LispObject execute(LispObject string, LispObject start, + LispObject end) { StringIndicesAndChars indicesAndChars = - stringIndicesAndChars(first, second, third); - AbstractString string = indicesAndChars.string1; + stringIndicesAndChars(string, start, end); + AbstractString retString = indicesAndChars.string1; for (int i = indicesAndChars.start1; i < indicesAndChars.end1; i++) - string.setCharAt(i, - LispCharacter.toUpperCase(string.charAt(i))); - return string; + retString.setCharAt(i, + LispCharacter. + toUpperCase( + retString.charAt(i))); + return retString; } }; @@ -668,17 +673,18 @@ } @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) + public LispObject execute(LispObject string, LispObject start, + LispObject end) { StringIndicesAndChars indicesAndChars = - stringIndicesAndChars(first, second, third); - AbstractString string = indicesAndChars.string1; + stringIndicesAndChars(string, start, end); + AbstractString retString = indicesAndChars.string1; for (int i = indicesAndChars.start1; i < indicesAndChars.end1; i++) - string.setCharAt(i, - LispCharacter.toLowerCase(string.charAt(i))); - return string; + retString.setCharAt(i, + LispCharacter. + toLowerCase(retString.charAt(i))); + return retString; } }; @@ -690,31 +696,31 @@ } @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) + public LispObject execute(LispObject string, LispObject start, + LispObject end) { StringIndicesAndChars indicesAndChars = - stringIndicesAndChars(first, second, third); + stringIndicesAndChars(string, start, end); boolean lastCharWasAlphanumeric = false; - AbstractString string = indicesAndChars.string1; + AbstractString retString = indicesAndChars.string1; for (int i = indicesAndChars.start1; i < indicesAndChars.end1; i++) { - char c = string.charAt(i); + char c = retString.charAt(i); if (Character.isLowerCase(c)) { if (!lastCharWasAlphanumeric) - string.setCharAt(i, - LispCharacter.toUpperCase(c)); + retString.setCharAt(i, + LispCharacter.toUpperCase(c)); lastCharWasAlphanumeric = true; } else if (Character.isUpperCase(c)) { if (lastCharWasAlphanumeric) - string.setCharAt(i, - LispCharacter.toLowerCase(c)); + retString.setCharAt(i, + LispCharacter.toLowerCase(c)); lastCharWasAlphanumeric = true; } else lastCharWasAlphanumeric = Character.isDigit(c); } - return string; + return retString; } }; From vvoutilainen at common-lisp.net Sun Feb 21 17:29:42 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 21 Feb 2010 12:29:42 -0500 Subject: [armedbear-cvs] r12496 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Feb 21 12:29:39 2010 New Revision: 12496 Log: Consolidate case-sensitive/insensitive comparisons. Modified: trunk/abcl/src/org/armedbear/lisp/StringFunctions.java Modified: trunk/abcl/src/org/armedbear/lisp/StringFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StringFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StringFunctions.java Sun Feb 21 12:29:39 2010 @@ -38,7 +38,8 @@ import java.util.Arrays; public final class StringFunctions { private final static class StringIndicesAndChars { - AbstractString string1; + public AbstractString string1; + public boolean convertCase = false; public char[] array1; public char[] array2; public int start1 = 0; @@ -79,6 +80,10 @@ } } + + private final static char upcaseIfNeeded(char c, boolean convert) { + return convert ? LispCharacter.toUpperCase(c) : c; + } private final static StringIndicesAndChars stringIndicesAndChars(LispObject... params) { @@ -270,8 +275,10 @@ // Reached end of string2. return -1; } - char c1 = indicesAndChars.array1[i]; - char c2 = indicesAndChars.array2[j]; + char c1 = upcaseIfNeeded(indicesAndChars.array1[i], + indicesAndChars.convertCase); + char c2 = upcaseIfNeeded(indicesAndChars.array2[j], + indicesAndChars.convertCase); if (c1 == c2) { ++i; ++j; @@ -349,8 +356,10 @@ // Reached end of string2. return -1; } - char c1 = indicesAndChars.array1[i]; - char c2 = indicesAndChars.array2[j]; + char c1 = upcaseIfNeeded(indicesAndChars.array1[i], + indicesAndChars.convertCase); + char c2 = upcaseIfNeeded(indicesAndChars.array2[j], + indicesAndChars.convertCase); if (c1 == c2) { ++i; ++j; @@ -405,33 +414,7 @@ } }; - private static int stringLessp(StringIndicesAndChars indicesAndChars) { - int i = indicesAndChars.start1; - int j = indicesAndChars.start2; - while (true) { - if (i == indicesAndChars.end1) { - // Reached end of string1. - if (j == indicesAndChars.end2) - return -1; // Strings are identical. - return i; - } - if (j == indicesAndChars.end2) { - // Reached end of string2. - return -1; - } - char c1 = LispCharacter.toUpperCase(indicesAndChars.array1[i]); - char c2 = LispCharacter.toUpperCase(indicesAndChars.array2[j]); - if (c1 == c2) { - ++i; - ++j; - continue; - } - if (c1 > c2) - return -1; - // c1 < c2 - return i; - } - } + // ### %string-lessp // Case insensitive. private static final Primitive _STRING_LESSP = new pf__string_lessp(); @@ -447,7 +430,8 @@ StringIndicesAndChars indicesAndChars = stringIndicesAndChars(string1, string2, start1, end1, start2, end2); - int retVal = stringLessp(indicesAndChars); + indicesAndChars.convertCase = true; + int retVal = lessThan(indicesAndChars); return (retVal >= 0) ? Fixnum.getInstance(retVal) : NIL; } }; @@ -469,39 +453,11 @@ stringIndicesAndChars(string2, string1, start2, end2, start1, end1); - int tmp = stringLessp(indicesAndChars); + indicesAndChars.convertCase = true; + int tmp = lessThan(indicesAndChars); return swapReturnValue(tmp, indicesAndChars); } }; - - private static int stringNotLessp(StringIndicesAndChars indicesAndChars) { - int i = indicesAndChars.start1; - int j = indicesAndChars.start2; - while (true) { - if (i == indicesAndChars.end1) { - // Reached end of string1. - if (j == indicesAndChars.end2) - return i; // Strings are identical. - return -1; - } - if (j == indicesAndChars.end2) { - // Reached end of string2. - return i; - } - char c1 = LispCharacter.toUpperCase(indicesAndChars.array1[i]); - char c2 = LispCharacter.toUpperCase(indicesAndChars.array2[j]); - if (c1 == c2) { - ++i; - ++j; - continue; - } - if (c1 > c2) - return i; - // c1 < c2 - return -1; - } - } - // ### %string-not-lessp // Case insensitive. private static final Primitive _STRING_NOT_LESSP = new pf__string_not_lessp(); @@ -514,11 +470,14 @@ public LispObject execute(LispObject string1, LispObject string2, LispObject start1, LispObject end1, LispObject start2, LispObject end2) { + // note the swap of the strings and lengths here.. StringIndicesAndChars indicesAndChars = - stringIndicesAndChars(string1, string2, - start1, end1, start2, end2); - int retVal = stringNotLessp(indicesAndChars); - return (retVal >= 0) ? Fixnum.getInstance(retVal) : NIL; + stringIndicesAndChars(string2, string1, + start2, end2, + start1, end1); + indicesAndChars.convertCase = true; + int tmp = lessThanOrEqual(indicesAndChars); + return swapReturnValue(tmp, indicesAndChars); } }; @@ -534,13 +493,13 @@ public LispObject execute(LispObject string1, LispObject string2, LispObject start1, LispObject end1, LispObject start2, LispObject end2) { - // note the swap of the strings and lengths here.. StringIndicesAndChars indicesAndChars = - stringIndicesAndChars(string2, string1, - start2, end2, - start1, end1); - int tmp = stringNotLessp(indicesAndChars); - return swapReturnValue(tmp, indicesAndChars); + stringIndicesAndChars(string1, string2, + start1, end1, + start2, end2); + indicesAndChars.convertCase = true; + int tmp = lessThanOrEqual(indicesAndChars); + return (tmp >= 0) ? Fixnum.getInstance(tmp) : NIL; } }; From vvoutilainen at common-lisp.net Sun Feb 21 17:46:10 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 21 Feb 2010 12:46:10 -0500 Subject: [armedbear-cvs] r12497 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Feb 21 12:46:10 2010 New Revision: 12497 Log: Consolidate string equality comparisons. Modified: trunk/abcl/src/org/armedbear/lisp/StringFunctions.java Modified: trunk/abcl/src/org/armedbear/lisp/StringFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StringFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StringFunctions.java Sun Feb 21 12:46:10 2010 @@ -162,6 +162,29 @@ }; + private static final int notEqual(StringIndicesAndChars indicesAndChars) { + int i = indicesAndChars.start1; + int j = indicesAndChars.start2; + while (true) { + if (i == indicesAndChars.end1) { + // Reached end of string1. + if (j == indicesAndChars.end2) + return -1; // Strings are identical. + return i; + } + if (j == indicesAndChars.end2) { + // Reached end of string2 before end of string1. + return i; + } + if (upcaseIfNeeded(indicesAndChars.array1[i], + indicesAndChars.convertCase) + != upcaseIfNeeded(indicesAndChars.array2[j], + indicesAndChars.convertCase)) + return i; + ++i; + ++j; + } + } // ### %string/= // Case sensitive. private static final Primitive _STRING_NOT_EQUAL = new pf__string_not_equal(); @@ -177,24 +200,8 @@ StringIndicesAndChars indicesAndChars = stringIndicesAndChars(string1, string2, start1, end1, start2, end2); - int i = indicesAndChars.start1; - int j = indicesAndChars.start2; - while (true) { - if (i == indicesAndChars.end1) { - // Reached end of string1. - if (j == indicesAndChars.end2) - return NIL; // Strings are identical. - return Fixnum.getInstance(i); - } - if (j == indicesAndChars.end2) { - // Reached end of string2 before end of string1. - return Fixnum.getInstance(i); - } - if (indicesAndChars.array1[i] != indicesAndChars.array2[j]) - return Fixnum.getInstance(i); - ++i; - ++j; - } + int tmp = notEqual(indicesAndChars); + return (tmp >= 0) ? Fixnum.getInstance(tmp) : NIL; } }; @@ -234,34 +241,13 @@ StringIndicesAndChars indicesAndChars = stringIndicesAndChars(string1, string2, start1, end1, start2, end2); - int i = indicesAndChars.start1; - int j = indicesAndChars.start2; - while (true) { - if (i == indicesAndChars.end1) { - // Reached end of string1. - if (j == indicesAndChars.end2) - return NIL; // Strings are identical. - return Fixnum.getInstance(i); - } - if (j == indicesAndChars.end2) { - // Reached end of string2. - return Fixnum.getInstance(i); - } - char c1 = indicesAndChars.array1[i]; - char c2 = indicesAndChars.array2[j]; - if (c1 == c2 || - LispCharacter.toUpperCase(c1) == LispCharacter.toUpperCase(c2) || - LispCharacter.toLowerCase(c1) == LispCharacter.toLowerCase(c2)) { - ++i; - ++j; - continue; - } - return Fixnum.getInstance(i); - } + indicesAndChars.convertCase = true; + int tmp = notEqual(indicesAndChars); + return (tmp >= 0) ? Fixnum.getInstance(tmp) : NIL; } }; - private static int lessThan(StringIndicesAndChars indicesAndChars) { + private static final int lessThan(StringIndicesAndChars indicesAndChars) { int i = indicesAndChars.start1; int j = indicesAndChars.start2; while (true) { @@ -344,7 +330,7 @@ } }; - private static int lessThanOrEqual(StringIndicesAndChars indicesAndChars) { + private static final int lessThanOrEqual(StringIndicesAndChars indicesAndChars) { int i = indicesAndChars.start1; int j = indicesAndChars.start2; while (true) { From mevenson at common-lisp.net Mon Feb 22 07:16:27 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 22 Feb 2010 02:16:27 -0500 Subject: [armedbear-cvs] r12498 - trunk/abcl Message-ID: Author: mevenson Date: Mon Feb 22 02:16:24 2010 New Revision: 12498 Log: Start noting changes for upcoming release. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Mon Feb 22 02:16:24 2010 @@ -1,3 +1,38 @@ +Version 0.19 +============ +(Unreleased) + +Features: + + +Fixes/Optimizations: + +* The REFERENCES-NEEDED-P field of the LOCAL-FUNCTION structure now + tracks whether local functions need the capture of an actual + function object. + +* Make NIL (as symbol) available to the compiler. + +* Move lambda list analysis to compile time where possible. + +* BROADCAST-STREAM obeys default external format fixing ANSI + MAKE-BROADCAST-STREAM.8. + +* Improve arglist display for SLIME (Matthias H?zl). + +* Optimize array utilization in closures. + +* Optimize array functions in compiler which don't require clearing + the VALUES array. + +* Optimize/normalize aspects of boot.lisp + +* Prevent duplicated subclasses. + +* Print Java objects with PRINT-OBJECT when *PRINT-PRETTY* is false + (Alan Ruttenberg). + + Version 0.18.1 ============== svn://common-lisp.net/project/armedbear/svn/tags/0.18.1/abcl From mevenson at common-lisp.net Mon Feb 22 10:02:38 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 22 Feb 2010 05:02:38 -0500 Subject: [armedbear-cvs] r12499 - trunk/abcl Message-ID: Author: mevenson Date: Mon Feb 22 05:02:34 2010 New Revision: 12499 Log: Further annotation for upcoming release. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Mon Feb 22 05:02:34 2010 @@ -1,37 +1,183 @@ Version 0.19 ============ +svn://common-lisp.net/project/armedbear/svn/trunk/abcl (Unreleased) -Features: +Features +-------- +* [svn 12487] An initial port ASDF-INSTALL now forms the first ABCL + contrib which are optionally built by the Ant target 'abcl.contrib'. + ASDF-INSTALL is not expected to work very well under Windows at the + moment. -Fixes/Optimizations: +* [svn 12447] REQUIRE now searches for ASDF systems. -* The REFERENCES-NEEDED-P field of the LOCAL-FUNCTION structure now - tracks whether local functions need the capture of an actual - function object. +* [svn r12422] Jar pathname support extensively re-worked and tested + so that LOAD, PROBE-FILE, TRUENAME, and WRITE-FILE-DATE all work + both for local and remote jar pathnames of the form + "jar:URL!/JAR-ENTRY". + + Loading ASDF systems from jar files are now possible. + + SYS:PATHNAME-JAR-P predicate signals whether a pathname refences a + jar. + + NB: jar pathnames do *not* currently work as an argument to OPEN or + DIRECTORY. + + SYS:UNZIP implemented to unpack ZIP files. + + SYS:ZIP now has a three argument version for creating zip files with + hierarchical entries. + +* [svn r12414] SYS::%GET-OUTPUT-STREAM-ARRAY returns a Lisp byte array + from a Java byte array stream. + +* [svn 12402] ABCL.TEST.LISP:RUN-MATCHING will now execute that subset + of tests which match a string. + + +Fixes/Optimizations +------------------- -* Make NIL (as symbol) available to the compiler. +* [svn r12485] Pathnames starting with "." can now have TYPE. -* Move lambda list analysis to compile time where possible. +* [svn r12484] FASLS containing "." characters not used to indicate + type (i.e. ".foo.bar.baz.abcl") can now be loaded. -* BROADCAST-STREAM obeys default external format fixing ANSI - MAKE-BROADCAST-STREAM.8. +* [svn 12422] Pathname.java URL contructor under Windows now properly + interprets the drive letter. -* Improve arglist display for SLIME (Matthias H?zl). +* [svn r12449] The 'abcl.jar' produced by Netbeans now contains a valid + manifest (found by Paul Griffionen). -* Optimize array utilization in closures. +* [svn r12441] ZipCache now caches all references to ZipFiles based on + the last-modified time for local files. Remote files are always + retrieved due to problems in the underlying JVM code. + + SYS:REMOVE-ZIP-CACHE implements a way to invalidate an entry given a + pathname. -* Optimize array functions in compiler which don't require clearing - the VALUES array. +* [svn r12439] Remove duplication of java options in Windows + 'abcl.bat' script. -* Optimize/normalize aspects of boot.lisp +* [svn r12437] CHAR-CODE-LIMIT is the upper execlusive limit (found by + Paul Griffionen). -* Prevent duplicated subclasses. +* [svn r12436] Describe formatting missing a newline (reported by + Blake McBride). -* Print Java objects with PRINT-OBJECT when *PRINT-PRETTY* is false +* [svn 12469] Ensure that FILE-ERROR always has a value (possibly NIL) + for its PATHNAME member. + +* [svn r14222] MERGE-PATHNAMES no longer potentially shares between + result and *DEFAULT-PATHNAME-DEFAULTS*. + +* [svn r12416] Fixed ANSI LAMBDA.nn test failures caused by errors in + lambda inlining. + +* [svn r12417] [ticket:83] Fix TRANSLATE-LOGICAL-PATHNAME regression. (Alan Ruttenberg). +* [svn r12412] Optimize memory efficiency of FORMAT by use of a + hashtable rather than a CHAR-CODE-LIMIT array. + +* [svn r12408] FIND-SYMBOL requires a string argument. + +* [svn r12400] Make NIL (as symbol) available to the compiler. + +* [svn r12398] Move lambda list analysis to compile time where possible. + +* [svn r12397] BROADCAST-STREAM obeys default external format fixing + ANSI MAKE-BROADCAST-STREAM.8. + +* [svn r12395] Improve arglist display for SLIME (Matthias H?zl). + +* [svn r12394] Optimize array utilization in closures. + +* [svn r12393] Optimize array functions in compiler which don't + require clearing the VALUES array. + +* [svn r12392] Optimize/normalize aspects of boot.lisp + +* [svn r12391] Prevent duplicated subclasses form occuring. + + +Other +----- + +* [svn 12447] SYS::*MODULE-PROVIDER-FUNCTION* now provides a mechanism + to extend the REQUIRE resolver mechanism at runtime. + +* [svn r12430] Ant based build no longer writes temporary files to + contain the Lisp build instructions. + +* [svn r12481] STANDARD-CLASS now has slots to be inherited by + deriving metaclasses in support of the (in progress) work on + metaclass. + +* [svn r12425] No longer ignore the METACLASS defclass option in + support of the (in progress) work on metaclass + +* [svn r12422] SYS::*LOAD-TRUENAME-FASL* now contains the TRUENAME of + the Java "*.cls" component we loading a packed FASL. + +* [svn r12461] Human readable Java representations for class cast + exceptions for NULL and UNBOUND values. + +* [svn 12453 et. ff.] Large numbers of Java primitives have been + declared in a way so that a stack trace provides a much more + readable indication of what has been invoked. Primitives which + extend Primitive are prefixed with "pf_"; those which extend + SpecialOperator are prefixed with "sf_". + +* [svn 12422] The internal structure of a jar pathname has changed. + Previously a pathname with a DEVICE that was itself a pathname + referenced a jar. This convention was not able to simultaneously + represent both jar entries that were themselves jar files (as occurs + with packed FASLs within JARs) and devices which refer to drive + letters under Windows. Now, a pathname which refers to a jar has a + DEVICE which is a proper list of at most two entries. The first + entry always references the "outer jar", and the second entry (if it + exists) references the "inner jar". + +* [svn r12419] Ant 'abcl.release' target centralizes the build steps + necessary for creating releases. + +* [svn r12409] Compiler now rewrites function calls with (LAMBDA ?) as + the operator to LET* forms. + +* [svn r12415] CLASS-FILE renamed to ABCL-CLASS-FILE to prepare for + (in progress) reworking of Stream inheritance. + +* [svn r123406] 'test/lisp/abcl/bugs.lisp' forms a default location to + add unit tests for current bug testing. The intention is to move + these tests into the proper location elsewhere in the test suite + once they have been fixed. + +* [svn r124040] Java tests upgraded to use junit-4.8.1. Netbeans + project runtime classpath now uses compilation results before source + directory, allowing the invocation of ABCL in interpreted mode if + the Ant 'abcl.compile.lisp.skip' property is set. Java unit tests + for some aspects of jar pathname work added. + +* New toplevel 'doc' directory now contains: + + + [svn r12410] Design for the (in progress) reworking of the Stream + inheritance. + + + [svn r12433] Design and current status for the re-implementation + of jar pathnames. + +* [svn r12402] Change ABCL unit tests to use the ABCL-TEST-LISP definition + contained in 'abcl.asd'. Fixed and renabled math-tests. Added new + tests for work related to handling jar pathnames. + +* [svn r12401] The REFERENCES-NEEDED-P field of the LOCAL-FUNCTION structure now + tracks whether local functions need the capture of an actual + function object. + Version 0.18.1 ============== From mevenson at common-lisp.net Mon Feb 22 11:12:21 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 22 Feb 2010 06:12:21 -0500 Subject: [armedbear-cvs] r12500 - trunk/abcl Message-ID: Author: mevenson Date: Mon Feb 22 06:12:19 2010 New Revision: 12500 Log: Correct contributor's last name spelling. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Mon Feb 22 06:12:19 2010 @@ -92,7 +92,7 @@ * [svn r12397] BROADCAST-STREAM obeys default external format fixing ANSI MAKE-BROADCAST-STREAM.8. -* [svn r12395] Improve arglist display for SLIME (Matthias H?zl). +* [svn r12395] Improve arglist display for SLIME (Matthias H?lzl). * [svn r12394] Optimize array utilization in closures. From mevenson at common-lisp.net Mon Feb 22 13:44:46 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 22 Feb 2010 08:44:46 -0500 Subject: [armedbear-cvs] r12501 - trunk/abcl Message-ID: Author: mevenson Date: Mon Feb 22 08:44:43 2010 New Revision: 12501 Log: Improve CHANGES for upcoming release. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Mon Feb 22 08:44:43 2010 @@ -7,20 +7,20 @@ -------- * [svn 12487] An initial port ASDF-INSTALL now forms the first ABCL - contrib which are optionally built by the Ant target 'abcl.contrib'. - ASDF-INSTALL is not expected to work very well under Windows at the - moment. + contrib. Such contribs are optionally built by the Ant target + 'abcl.contrib'. ASDF-INSTALL is not expected to work very well + under Windows in its present state. -* [svn 12447] REQUIRE now searches for ASDF systems. +* [svn 12447] [ticket:80] REQUIRE now searches for ASDF systems. * [svn r12422] Jar pathname support extensively re-worked and tested so that LOAD, PROBE-FILE, TRUENAME, and WRITE-FILE-DATE all work both for local and remote jar pathnames of the form "jar:URL!/JAR-ENTRY". - Loading ASDF systems from jar files are now possible. + The loading ASDF systems from jar files is now possible. - SYS:PATHNAME-JAR-P predicate signals whether a pathname refences a + SYS:PATHNAME-JAR-P predicate signals whether a pathname references a jar. NB: jar pathnames do *not* currently work as an argument to OPEN or @@ -31,6 +31,9 @@ SYS:ZIP now has a three argument version for creating zip files with hierarchical entries. +* [svn r12450] Collect unprocessed command-line arguments in + EXT:*COMMAND-LINE-ARGUMENT-LIST* (Dennis Lambe Jr.) + * [svn r12414] SYS::%GET-OUTPUT-STREAM-ARRAY returns a Lisp byte array from a Java byte array stream. @@ -43,7 +46,7 @@ * [svn r12485] Pathnames starting with "." can now have TYPE. -* [svn r12484] FASLS containing "." characters not used to indicate +* [svn r12484] FASLs containing "." characters not used to indicate type (i.e. ".foo.bar.baz.abcl") can now be loaded. * [svn 12422] Pathname.java URL contructor under Windows now properly @@ -65,14 +68,14 @@ * [svn r12437] CHAR-CODE-LIMIT is the upper execlusive limit (found by Paul Griffionen). -* [svn r12436] Describe formatting missing a newline (reported by +* [svn r12436] Describe formatting was missing a newline (reported by Blake McBride). * [svn 12469] Ensure that FILE-ERROR always has a value (possibly NIL) for its PATHNAME member. -* [svn r14222] MERGE-PATHNAMES no longer potentially shares between - result and *DEFAULT-PATHNAME-DEFAULTS*. +* [svn r14222] MERGE-PATHNAMES no longer potentially shares structure + between its result and *DEFAULT-PATHNAME-DEFAULTS*. * [svn r12416] Fixed ANSI LAMBDA.nn test failures caused by errors in lambda inlining. @@ -121,16 +124,16 @@ support of the (in progress) work on metaclass * [svn r12422] SYS::*LOAD-TRUENAME-FASL* now contains the TRUENAME of - the Java "*.cls" component we loading a packed FASL. + the Java "*.cls" component when loading a packed FASL. * [svn r12461] Human readable Java representations for class cast exceptions for NULL and UNBOUND values. -* [svn 12453 et. ff.] Large numbers of Java primitives have been - declared in a way so that a stack trace provides a much more - readable indication of what has been invoked. Primitives which - extend Primitive are prefixed with "pf_"; those which extend - SpecialOperator are prefixed with "sf_". +* [svn 12453 et. ff.] Large numbers of the implementation of Java + primitives have been declared in a way so that a stack trace + provides a much more readable indication of what has been invoked. + Primitives which extend Primitive are prefixed with "pf_"; those + which extend SpecialOperator are prefixed with "sf_". * [svn 12422] The internal structure of a jar pathname has changed. Previously a pathname with a DEVICE that was itself a pathname From mevenson at common-lisp.net Mon Feb 22 14:46:00 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 22 Feb 2010 09:46:00 -0500 Subject: [armedbear-cvs] r12502 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Feb 22 09:45:59 2010 New Revision: 12502 Log: ABCL system code should be platform agnostic at runtime. Use (featurep :windows) rather than #+windows so that the compiled code will work the same no matter where it is compiled. 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 Mon Feb 22 09:45:59 2010 @@ -75,10 +75,10 @@ (wild-pathname-p pathname)) (let ((namestring (directory-namestring pathname))) (when (and namestring (> (length namestring) 0)) - #+windows - (let ((device (pathname-device pathname))) - (when device - (setq namestring (concatenate 'string device ":" namestring)))) + (when (featurep :windows) + (let ((device (pathname-device pathname))) + (when device + (setq namestring (concatenate 'string device ":" namestring))))) (let ((entries (list-directories-with-wildcards namestring)) (matching-entries ())) (dolist (entry entries) From mevenson at common-lisp.net Mon Feb 22 16:32:47 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 22 Feb 2010 11:32:47 -0500 Subject: [armedbear-cvs] r12503 - in trunk/abcl: . doc/design/pathnames src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Feb 22 11:32:45 2010 New Revision: 12503 Log: DIRECTORY now works for jar pathnames. The semantics for listing directories are a little bit different from DIRECTORY on filesystems because directory entries in jar files *always* have a trailing '/'. Modified: trunk/abcl/CHANGES trunk/abcl/doc/design/pathnames/abcl-jar-url.text trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/src/org/armedbear/lisp/directory.lisp Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Mon Feb 22 11:32:45 2010 @@ -14,8 +14,8 @@ * [svn 12447] [ticket:80] REQUIRE now searches for ASDF systems. * [svn r12422] Jar pathname support extensively re-worked and tested - so that LOAD, PROBE-FILE, TRUENAME, and WRITE-FILE-DATE all work - both for local and remote jar pathnames of the form + so that LOAD, PROBE-FILE, TRUENAME, DIRECTORY, and WRITE-FILE-DATE + all work both for local and remote jar pathnames of the form "jar:URL!/JAR-ENTRY". The loading ASDF systems from jar files is now possible. @@ -23,8 +23,7 @@ SYS:PATHNAME-JAR-P predicate signals whether a pathname references a jar. - NB: jar pathnames do *not* currently work as an argument to OPEN or - DIRECTORY. + NB: jar pathnames do *not* currently work as an argument to OPEN. SYS:UNZIP implemented to unpack ZIP files. Modified: trunk/abcl/doc/design/pathnames/abcl-jar-url.text ============================================================================== --- trunk/abcl/doc/design/pathnames/abcl-jar-url.text (original) +++ trunk/abcl/doc/design/pathnames/abcl-jar-url.text Mon Feb 22 11:32:45 2010 @@ -3,7 +3,7 @@ Mark Evenson Created: 09 JAN 2010 -Modified: 08 FEB 2010 +Modified: 22 FEB 2010 Notes towards sketching an implementation of "jar:" references to be contained in PATHNAMEs within ABCL. @@ -53,11 +53,9 @@ Status ------ -As of svn r12431, all the above goals have been implemented and tested +As of svn r12501, all the above goals have been implemented and tested *except* for: -5. DIRECTORY working within JAR files - 7. Make jar pathnames work as a valid argument for OPEN. 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 Mon Feb 22 11:32:45 2010 @@ -38,19 +38,14 @@ import java.io.IOException; import java.io.InputStream; import java.io.FileInputStream; -import java.net.JarURLConnection; import java.net.MalformedURLException; import java.net.URL; -import java.net.URLConnection; import java.net.URLDecoder; -import java.util.HashMap; +import java.util.Enumeration; import java.util.StringTokenizer; -import java.util.jar.JarEntry; -import java.util.jar.JarFile; import java.util.zip.ZipEntry; import java.util.zip.ZipFile; import java.util.zip.ZipInputStream; -import java.util.zip.ZipException; public class Pathname extends LispObject { @@ -1246,6 +1241,20 @@ } } } + + private static Function pathname_match_p; + private static LispObject matchesWildcard(LispObject pathname, LispObject wildcard) { + if (pathname_match_p == null) { + pathname_match_p + = (Function) PACKAGE_SYS.findAccessibleSymbol("PATHNAME-MATCH-P") + .getSymbolFunction(); + if (pathname_match_p == null) { + Debug.assertTrue(false); + } + } + return pathname_match_p.execute(pathname, wildcard); + } + // ### list-directory directory private static final Primitive LIST_DIRECTORY = new pf_list_directory(); private static class pf_list_directory extends Primitive { @@ -1258,10 +1267,53 @@ if (pathname instanceof LogicalPathname) { pathname = LogicalPathname.translateLogicalPathname((LogicalPathname) pathname); } + + LispObject result = NIL; if (pathname.isJar()) { - return error(new FileError("Unimplemented directory listing of JAR files.", pathname)); + String directory = pathname.asEntryPath(); + Debug.assertTrue(directory != null); // We should only be listing directories + + if (pathname.device.cdr() instanceof Cons) { + return error(new FileError("Unimplemented directory listing of JAR within JAR.", pathname)); + } + + if (directory.length() == 0) { + directory = "/*"; + } else { + if (directory.endsWith("/")) { + directory = "/" + directory + "*"; + } else { + directory = "/" + directory + "/*"; + } + } + SimpleString wildcard = new SimpleString(directory); + SimpleString wildcardDirectory = new SimpleString(directory + "/"); + + ZipFile jar = ZipCache.get(pathname.device.car()); + LispObject matches; + for (Enumeration entries = jar.entries(); + entries.hasMoreElements();) { + ZipEntry entry = entries.nextElement(); + String entryName = "/" + entry.getName(); + + if (entryName.endsWith("/")) { + matches = matchesWildcard(new SimpleString(entryName), + wildcardDirectory); + } else { + matches = matchesWildcard(new SimpleString(entryName), + wildcard); + } + if (!matches.equals(NIL)) { + String namestring = new String(pathname.getNamestring()); + namestring = namestring.substring(0, namestring.lastIndexOf("!/") + 2) + + entry.getName(); + Pathname p = new Pathname(namestring); + result = new Cons(p, result); + } + } + return result; } - LispObject result = NIL; + String s = pathname.getNamestring(); if (s != null) { File f = new File(s); @@ -1292,6 +1344,62 @@ } } + // ### match-wild-jar-pathname wild-jar-pathname + private static final Primitive LIST_JAR_DIRECTORY = new pf_match_wild_jar_pathname(); + private static class pf_match_wild_jar_pathname extends Primitive { + pf_match_wild_jar_pathname() { + super("match-wild-jar-pathname", PACKAGE_SYS, false, "wild-jar-pathname"); + } + @Override + public LispObject execute(LispObject arg) { + Pathname pathname = coerceToPathname(arg); + if (pathname instanceof LogicalPathname) { + pathname = LogicalPathname.translateLogicalPathname((LogicalPathname) pathname); + } + if (!pathname.isJar()) { + return new FileError("Not a jar pathname.", pathname); + } + if (!pathname.isWild()) { + return new FileError("Not a wild pathname.", pathname); + } + Pathname jarPathname = new Pathname(pathname); + jarPathname.directory = NIL; + jarPathname.name = NIL; + jarPathname.type = NIL; + jarPathname.invalidateNamestring(); + // will propagate an appropiate Lisp error if jarPathname + // doesn't exist. + LispObject jarTruename = truename(jarPathname, true); + + LispObject result = NIL; + String wild = "/" + pathname.asEntryPath(); + + if (pathname.device.cdr() instanceof Cons) { + return error(new FileError("Unimplemented directory listing of JAR within JAR.", pathname)); + } + + final SimpleString wildcard = new SimpleString(wild); + + ZipFile jar = ZipCache.get(pathname.device.car()); + + for (Enumeration entries = jar.entries(); entries.hasMoreElements();) { + ZipEntry entry = entries.nextElement(); + String entryName = "/" + entry.getName(); + + LispObject matches = matchesWildcard(new SimpleString(entryName), wildcard); + + if (!matches.equals(NIL)) { + String namestring = new String(pathname.getNamestring()); + namestring = namestring.substring(0, namestring.lastIndexOf("!/") + 2) + + entry.getName(); + Pathname p = new Pathname(namestring); + result = new Cons(p, result); + } + } + return result; + } + } + public boolean isAbsolute() { if (!directory.equals(NIL) || !(directory == null)) { if (directory instanceof Cons) { 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 Mon Feb 22 11:32:45 2010 @@ -53,18 +53,20 @@ :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)))) + 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)))) (defun directory (pathspec &key) @@ -73,21 +75,23 @@ (setq pathname (translate-logical-pathname pathname))) (if (or (position #\* (namestring pathname)) (wild-pathname-p pathname)) - (let ((namestring (directory-namestring pathname))) - (when (and namestring (> (length namestring) 0)) - (when (featurep :windows) - (let ((device (pathname-device pathname))) - (when device - (setq namestring (concatenate 'string device ":" namestring))))) - (let ((entries (list-directories-with-wildcards namestring)) - (matching-entries ())) - (dolist (entry entries) - (cond ((file-directory-p entry) - (when (pathname-match-p (file-namestring (pathname-as-file entry)) (file-namestring pathname)) - (push entry matching-entries))) - ((pathname-match-p (file-namestring entry) (file-namestring pathname)) - (push entry matching-entries)))) - matching-entries))) + (if (pathname-jar-p pathname) + (match-wild-jar-pathname pathname) + (let ((namestring (directory-namestring pathname))) + (when (and namestring (> (length namestring) 0)) + (when (featurep :windows) + (let ((device (pathname-device pathname))) + (when device + (setq namestring (concatenate 'string device ":" namestring))))) + (let ((entries (list-directories-with-wildcards namestring)) + (matching-entries ())) + (dolist (entry entries) + (cond ((file-directory-p entry) + (when (pathname-match-p (file-namestring (pathname-as-file entry)) (file-namestring pathname)) + (push entry matching-entries))) + ((pathname-match-p (file-namestring entry) (file-namestring pathname)) + (push entry matching-entries)))) + matching-entries)))) ;; Not wild. (let ((truename (probe-file pathname))) (if truename From mevenson at common-lisp.net Tue Feb 23 14:34:48 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 23 Feb 2010 09:34:48 -0500 Subject: [armedbear-cvs] r12504 - in trunk/abcl/src/org/armedbear/lisp: . util Message-ID: Author: mevenson Date: Tue Feb 23 09:34:45 2010 New Revision: 12504 Log: Implement HTTP HEAD Last-Modified checking for ZipCache objects. Since it seems that no Sun-derived JVM ever invalidates its cache of URLConnection objects, we have to check for modification "manually". This implementation is "better than nothing", but not expected to be especially robust. Most notably, this implementation does not attempt to use http proxies if they have been specified to the JVM by the 'http.proxy' system property. Added: trunk/abcl/src/org/armedbear/lisp/util/HttpHead.java (contents, props changed) 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 Tue Feb 23 09:34:45 2010 @@ -32,21 +32,21 @@ */ package org.armedbear.lisp; - +import org.armedbear.lisp.util.HttpHead; import static org.armedbear.lisp.Lisp.*; import java.io.File; -import java.io.InputStream; import java.io.IOException; import java.net.JarURLConnection; import java.net.MalformedURLException; import java.net.URL; import java.net.URLConnection; -import java.util.Enumeration; +import java.text.ParseException; +import java.text.SimpleDateFormat; +import java.util.Date; import java.util.HashMap; import java.util.zip.ZipException; import java.util.zip.ZipFile; -import java.util.zip.ZipEntry; /** * A cache for all zip/jar file accesses by URL that uses the last @@ -67,7 +67,7 @@ // that keeps track of the number of outstanding references handed // out, not allowing ZipFile.close() to succeed until that count // has been reduced to 1 or the finalizer is executing. - // Unfortunately the relatively simple strategy of extended + // Unfortunately the relatively simple strategy of extending // ZipFile via a CachedZipFile does not work because there is not // a null arg constructor for ZipFile. static class Entry { @@ -101,6 +101,9 @@ return get(Pathname.makeURL(arg)); } + static final SimpleDateFormat RFC_1123 + = new SimpleDateFormat("EEE, dd MMM yyyy HH:mm:ss zzz"); + synchronized public static ZipFile get(final URL url) { if (!cacheEnabled) { if (url.getProtocol().equals("file")) { @@ -145,28 +148,31 @@ Debug.trace(e.toString()); // XXX } } - } else { + } else if (url.getProtocol().equals("http")) { // Unfortunately, the Apple JDK under OS X doesn't do // HTTP HEAD requests, instead refetching the entire - // resource, so the following code is a waste. I assume - // this is the case in all Sun-dervied JVMs. We'll have - // to implement a custom HTTP lastModified checker. - - // URLConnection connection; - // try { - // connection = url.openConnection(); - // } catch (IOException ex) { - // Debug.trace("Failed to open " - // + "'" + url + "'"); - // return null; - // } - // long current = connection.getLastModified(); - // if (current > entry.lastModified) { - // try { - // entry.file.close(); - // } catch (IOException ex) {} - // entry = fetchURL(url, false); - // } + // resource, and I assume this is the case in all + // Sun-derived JVMs. So, we use a custom HEAD + // implementation only looking for Last-Modified + // headers, which if we don't find, we give up and + // refetch the resource.n + String dateString = HttpHead.get(url, "Last-Modified"); + Date date = null; + try { + date = RFC_1123.parse(dateString); + long current = date.getTime(); + if (current > entry.lastModified) { + entry = fetchURL(url, false); + zipCache.put(url, entry); + } + } catch (ParseException e) { + Debug.trace("Failed to parse HTTP Last-Modified field: " + e); + entry = fetchURL(url, false); + zipCache.put(url, entry); + } + } else { + entry = fetchURL(url, false); + zipCache.put(url, entry); } } else { if (url.getProtocol().equals("file")) { Added: trunk/abcl/src/org/armedbear/lisp/util/HttpHead.java ============================================================================== --- (empty file) +++ trunk/abcl/src/org/armedbear/lisp/util/HttpHead.java Tue Feb 23 09:34:45 2010 @@ -0,0 +1,166 @@ +/* + * HttpHead.java + * + * Copyright (C) 2010 Mark Evenson + * $Id$ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ +package org.armedbear.lisp.util; + +import org.armedbear.lisp.Debug; + +import java.io.BufferedReader; +import java.io.IOException; +import java.io.InputStreamReader; +import java.io.PrintWriter; +import java.net.InetSocketAddress; +import java.net.MalformedURLException; +import java.net.Proxy; +import java.net.Socket; +import java.net.URL; + +/** + * Use HTTP/1.1 HEAD to retrieve the specified header field. + */ +public class HttpHead { + static private String get(String urlString, String key) { + URL url = null; + try { + url = new URL(urlString); + } catch (MalformedURLException e) { + log("Failed to form url from " + "'" + urlString + "'" + ": " + e); + } + return get(url, key); + } + + static public String get(URL url, String key) { + Socket socket = null; + String result = null; + try { + String protocol = url.getProtocol(); + if (!protocol.equals("http")) { + log("The protocol " + "'" + protocol + "'" + " is not http."); + return result; + } + + socket = new Socket(Proxy.NO_PROXY); // XXX add Proxy + + int port = url.getPort(); + if (port == -1) { + port = 80; + } + InetSocketAddress address = new InetSocketAddress(url.getHost(), port); + try { + socket.connect(address, 5000); // ??? too long? too short? + } catch (IOException ex) { + log("Connection failed: " + ex); + return result; + } + + PrintWriter out = null; + BufferedReader in = null; + try { + out = new PrintWriter(socket.getOutputStream()); + in = new BufferedReader(new InputStreamReader(socket.getInputStream())); + } catch (IOException e) { + log("Failed to establish socket io: " + e); + return result; + } + + String path = url.getPath(); + out.println("HEAD " + url + " HTTP/1.1"); + out.println("Connection: close"); + out.println(""); + out.flush(); + + String line = null; + try { + line = in.readLine(); + } catch (IOException e) { + log("Failed to read HTTP response: " + e); + } + String status[] = line.split("\\s"); + if (status[1].equals("200")) { + result = findHeader(in, key); + } else if (status[1].startsWith("3")) { + // Follow redirects ad nauseum + String location = findHeader(in, "Location"); + if (location != null) { + return get(location, key); + } + } else { + log("Unexpected response: " + line); + } + } finally { + try { + socket.close(); + } catch (IOException e) { + } + } + return result; + } + + static private String findHeader(BufferedReader in, String key) { + String result = null; + String line; + try { + while ((line = in.readLine()) != null) { + int i = line.indexOf(":"); + if (i == -1) { + continue; // XXX parse multi-line HTTP headers + } + String k = line.substring(0, i); + String v = line.substring(i + 1).trim(); + if (k.equals(key)) { + result = v; + break; + } + } + } catch (IOException e) { + log("Failed to read headers: " + e); + } + return result; + } + + static private void log(String message) { + Debug.warn(message); + } + + public static void main(String argv[]) { + if (argv.length != 1) { + System.out.println("Usage: URL"); + return; + } + String modified = get(argv[0], "Last-Modified"); + if (modified != null) { + System.out.println("Last-Modified: " + modified); + } else { + System.out.println("No result returned."); + } + } +} From astalla at common-lisp.net Tue Feb 23 23:35:20 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 23 Feb 2010 18:35:20 -0500 Subject: [armedbear-cvs] r12505 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Tue Feb 23 18:35:17 2010 New Revision: 12505 Log: Added missing copy-tree for the function body in one case of lambda inlining, which didn't play well with compiler macros (self-modifying code). Should fix the bug found by Alan Ruttenberg on 2010-02-16. 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 Tue Feb 23 18:35:17 2010 @@ -203,7 +203,6 @@ (push-argument-binding (var rest) `(list , at arguments) temp-bindings rest-binding) (setf bindings (append bindings rest-binding))))) - ;;Aux parameters. (when aux (setf bindings @@ -211,7 +210,6 @@ ,@(loop :for var-info :in aux :collect `(,(var var-info) ,(initform var-info)))))) - (values (append req-bindings temp-bindings bindings) ignorables))))) @@ -318,7 +316,8 @@ (parse-lambda-list lambda-list)) args) `(let* ,bindings - (declare (ignorable , at ignorables)) + ,@(when ignorables + `((declare (ignorable , at ignorables)))) , at body)) (lambda-list-mismatch (x) (compiler-warn "Invalid function call: ~S (mismatch type: ~A)" @@ -1248,7 +1247,7 @@ (args (cdr form))) (if (and (listp op) (eq (car op) 'lambda)) - (expand-function-call-inline form (cadr op) (cddr op) args) + (expand-function-call-inline form (cadr op) (copy-tree (cddr op)) args) (if (unsafe-p args) (let ((arg1 (car args))) (cond ((and (consp arg1) (eq (car arg1) 'GO)) @@ -1275,9 +1274,6 @@ (defun p1-function-call (form) (let ((new-form (rewrite-function-call form))) (when (neq new-form form) -;; (let ((*print-structure* nil)) -;; (format t "old form = ~S~%" form) -;; (format t "new form = ~S~%" new-form)) (return-from p1-function-call (p1 new-form)))) (let* ((op (car form)) (local-function (find-local-function op))) @@ -1463,4 +1459,4 @@ (setf (compiland-p1-result compiland) (list* 'LAMBDA lambda-list (p1-body body)))))) -(provide "COMPILER-PASS1") \ No newline at end of file +(provide "COMPILER-PASS1") From mevenson at common-lisp.net Wed Feb 24 10:06:46 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 24 Feb 2010 05:06:46 -0500 Subject: [armedbear-cvs] r12506 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Feb 24 05:06:43 2010 New Revision: 12506 Log: Eliminate needless lookup for PATHNAME-MATCH-P primitive. 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 Wed Feb 24 05:06:43 2010 @@ -1242,19 +1242,6 @@ } } - private static Function pathname_match_p; - private static LispObject matchesWildcard(LispObject pathname, LispObject wildcard) { - if (pathname_match_p == null) { - pathname_match_p - = (Function) PACKAGE_SYS.findAccessibleSymbol("PATHNAME-MATCH-P") - .getSymbolFunction(); - if (pathname_match_p == null) { - Debug.assertTrue(false); - } - } - return pathname_match_p.execute(pathname, wildcard); - } - // ### list-directory directory private static final Primitive LIST_DIRECTORY = new pf_list_directory(); private static class pf_list_directory extends Primitive { @@ -1297,11 +1284,11 @@ String entryName = "/" + entry.getName(); if (entryName.endsWith("/")) { - matches = matchesWildcard(new SimpleString(entryName), - wildcardDirectory); + matches = Symbol.PATHNAME_MATCH_P + .execute(new SimpleString(entryName), wildcardDirectory); } else { - matches = matchesWildcard(new SimpleString(entryName), - wildcard); + matches = Symbol.PATHNAME_MATCH_P. + execute(new SimpleString(entryName), wildcard); } if (!matches.equals(NIL)) { String namestring = new String(pathname.getNamestring()); @@ -1386,7 +1373,8 @@ ZipEntry entry = entries.nextElement(); String entryName = "/" + entry.getName(); - LispObject matches = matchesWildcard(new SimpleString(entryName), wildcard); + LispObject matches = Symbol.PATHNAME_MATCH_P + .execute(new SimpleString(entryName), wildcard); if (!matches.equals(NIL)) { String namestring = new String(pathname.getNamestring()); From astalla at common-lisp.net Wed Feb 24 22:33:43 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Wed, 24 Feb 2010 17:33:43 -0500 Subject: [armedbear-cvs] r12507 - trunk/abcl Message-ID: Author: astalla Date: Wed Feb 24 17:33:40 2010 New Revision: 12507 Log: Improve CHANGES for upcoming release. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Wed Feb 24 17:33:40 2010 @@ -6,6 +6,10 @@ Features -------- +* [svn 12505] All calls to anonymous functions and local functions that have + been declared inline are now converted to LET* forms, reducing stack usage + and the number of generated classes. + * [svn 12487] An initial port ASDF-INSTALL now forms the first ABCL contrib. Such contribs are optionally built by the Ant target 'abcl.contrib'. ASDF-INSTALL is not expected to work very well From mevenson at common-lisp.net Sat Feb 27 06:59:25 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 27 Feb 2010 01:59:25 -0500 Subject: [armedbear-cvs] r12508 - trunk/abcl/test/lisp/ansi Message-ID: Author: mevenson Date: Sat Feb 27 01:59:24 2010 New Revision: 12508 Log: Code for parsing ANSI errors database. Added: trunk/abcl/test/lisp/ansi/parse-ansi-errors.lisp Added: trunk/abcl/test/lisp/ansi/parse-ansi-errors.lisp ============================================================================== --- (empty file) +++ trunk/abcl/test/lisp/ansi/parse-ansi-errors.lisp Sat Feb 27 01:59:24 2010 @@ -0,0 +1,80 @@ +;;;; $Id$ +;;;; Parse ANSI test list +;;;; +;;;; 'cuz I get lost after comparing about five items in a list +;;;; + +#| + +To use + +1. create a "database" of test results consisting of S-exp of form + + (compileit|doit ()) + +where + + compileit|doit The symbol 'compileit' or 'doit' depending on + whether the compiled or interpreted tests were run. + + version A symbol identifying the version of source of the + tests. + + + The list of symbols failing the tests. + +An example: + +(compileit 0.18.1 (REINITIALIZE-INSTANCE.ERROR.1 DEFGENERIC.ERROR.20 +DEFGENERIC.ERROR.21 DEFGENERIC.30 CALL-NEXT-METHOD.ERROR.1 +CALL-NEXT-METHOD.ERROR.2 DEFMETHOD.ERROR.14 DEFMETHOD.ERROR.15 +MAKE-CONDITION.3 MAKE-CONDITION.4 DELETE-PACKAGE.5 DELETE-PACKAGE.6 +MAP.48 TYPE-OF.1 TYPE-OF.4 CHAR-UPCASE.2 CHAR-DOWNCASE.2 +ENSURE-DIRECTORIES-EXIST.8 FRESH-LINE.5 MAKE-BROADCAST-STREAM.8 +PRINT.BACKQUOTE.RANDOM.14 PRINT.RANDOM-STATE.1 PPRINT-FILL.14 +PPRINT-FILL.15 PPRINT-LINEAR.14 PPRINT-TABULAR.13 +PPRINT-LOGICAL-BLOCK.17 PPRINT-POP.7 PPRINT-POP.8 +FORMAT.LOGICAL-BLOCK.CIRCLE.1 FORMAT.LOGICAL-BLOCK.CIRCLE.2 +FORMAT.LOGICAL-BLOCK.CIRCLE.3 FORMAT.JUSTIFY.30 FORMAT.JUSTIFY.32 +WITH-STANDARD-IO-SYNTAX.23 TRACE.8)). + +2. Run (PARSE ) on the file of your database. + +3. Then differences between versions can be queried via DIFFERENCE + + CL-USER> (difference 'compileit '0.18.0 'r13590) + +|# + +(defvar *doit* (make-hash-table)) +(defvar *compileit* (make-hash-table)) + +(defun get-hash-table (test) + (getf `(doit ,*doit* compileit ,*compileit*) test)) + +(defun parse (&optional (file #p"failures") + (with-open-file (s file :direction :input) + (do ((form (read s) (read s nil nil))) + ((null form)) + (destructuring-bind (test version failures) form + (setf (gethash version + (get-hash-table test)) + failures))))) + +(defun versions (test) + (loop :for key :being :the :hash-keys :of (get-hash-table test) + :collecting key)) + +(defun difference (test version-1 version-2) + (let ((failures-1 (gethash version-1 (get-hash-table test))) + (failures-2 (gethash version-2 (get-hash-table test)))) + (format t "~A: ~A failures~% ~A~%" + version-1 (length failures-1) (set-difference failures-1 failures-2)) + (format t "~A: ~A failures~% ~A~%" + version-2 (length failures-2) (set-difference failures-2 failures-1))) + (values)) + + + + + \ No newline at end of file From mevenson at common-lisp.net Sat Feb 27 07:01:02 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 27 Feb 2010 02:01:02 -0500 Subject: [armedbear-cvs] r12509 - in trunk/abcl: . test/lisp/ansi Message-ID: Author: mevenson Date: Sat Feb 27 02:01:01 2010 New Revision: 12509 Log: ANSI test database can now contain multiple test results per version. We change the syntax of the ANSI test results database to allow the specification of a unique identifier plus other optional identifying information by allowing keyword/value pairs. The keyword :ID specifies the identifier, which should be a symbol. Other arbitrary keywords are allowed which specify additional information to be associated with the symbol specified by :ID in the *ID* hashtable. Not every test failure entry needs to specify this information. In case of duplicates, the last entry wins. Suggested other keywords are :JVM to specify the Java virtual machine, and :UNAME to specify the operating system/hardware combination in a GNU autoconf-like string. See the comments at the beginning of 'parse-ansi-errors.lisp' for more details. The utility has been packaged in ABCL.ANSI.TEST, showing up in the ANSI-COMPILED and ANSI-INTERPRETED ASDF systems loadable from 'abcl.asd'. A database of failures has been included in 'ansi-test-failures'. It is intended that other developers entrich this database with their own test results. Added: trunk/abcl/test/lisp/ansi/ansi-test-failures (contents, props changed) Modified: trunk/abcl/abcl.asd trunk/abcl/test/lisp/ansi/package.lisp trunk/abcl/test/lisp/ansi/parse-ansi-errors.lisp (contents, props changed) Modified: trunk/abcl/abcl.asd ============================================================================== --- trunk/abcl/abcl.asd (original) +++ trunk/abcl/abcl.asd Sat Feb 27 02:01:01 2010 @@ -46,10 +46,11 @@ (funcall (intern (symbol-name 'run) :abcl.test.lisp))) ;;; Test ABCL with the interpreted ANSI tests -(defsystem :ansi-interpreted :version "1.0.1" +(defsystem :ansi-interpreted :version "1.1" :components ((:module ansi-tests :pathname "test/lisp/ansi/" :components - ((:file "package"))))) + ((:file "package") + (:file "parse-ansi-errors" :depends-on ("package")))))) (defmethod perform :before ((o test-op) (c (eql (find-system :ansi-interpreted)))) (operate 'load-op :ansi-interpreted)) (defmethod perform ((o test-op) (c (eql (find-system :ansi-interpreted)))) @@ -57,10 +58,11 @@ :compile-tests nil)) ;;; Test ABCL with the compiled ANSI tests -(defsystem :ansi-compiled :version "1.0.1" +(defsystem :ansi-compiled :version "1.1" :components ((:module ansi-tests :pathname "test/lisp/ansi/" :components - ((:file "package"))))) + ((:file "package") + (:file "parse-ansi-errors" :depends-on ("package")))))) (defmethod perform :before ((o test-op) (c (eql (find-system :ansi-compiled)))) (operate 'load-op :ansi-compiled)) (defmethod perform ((o test-op) (c (eql (find-system :ansi-compiled)))) Added: trunk/abcl/test/lisp/ansi/ansi-test-failures ============================================================================== --- (empty file) +++ trunk/abcl/test/lisp/ansi/ansi-test-failures Sat Feb 27 02:01:01 2010 @@ -0,0 +1,178 @@ +;;;; -*- Mode: LISP; Syntax: COMMON-LISP -*- + +(doit r12506 :id dada + :uname "x64-darwin-10.2.0" :jvm "apple-jdk-1.6.0_17" + (REINITIALIZE-INSTANCE.ERROR.1 DEFGENERIC.ERROR.20 + DEFGENERIC.ERROR.21 DEFGENERIC.30 CALL-NEXT-METHOD.ERROR.1 + CALL-NEXT-METHOD.ERROR.2 DEFMETHOD.ERROR.14 DEFMETHOD.ERROR.15 + MAKE-CONDITION.3 MAKE-CONDITION.4 DELETE-PACKAGE.5 DELETE-PACKAGE.6 + MAP.48 TYPE-OF.1 TYPE-OF.4 CHAR-UPCASE.2 CHAR-DOWNCASE.2 + ENSURE-DIRECTORIES-EXIST.8 FRESH-LINE.5 PRINT.RANDOM-STATE.1 + PPRINT-FILL.14 PPRINT-FILL.15 PPRINT-LINEAR.14 PPRINT-TABULAR.13 + PPRINT-LOGICAL-BLOCK.17 PPRINT-POP.7 PPRINT-POP.8 + FORMAT.LOGICAL-BLOCK.CIRCLE.1 FORMAT.LOGICAL-BLOCK.CIRCLE.2 + FORMAT.LOGICAL-BLOCK.CIRCLE.3 FORMAT.JUSTIFY.30 FORMAT.JUSTIFY.32 + WITH-STANDARD-IO-SYNTAX.23)) + +(compileit r12506 :id dada + (REINITIALIZE-INSTANCE.ERROR.1 DEFGENERIC.ERROR.20 + DEFGENERIC.ERROR.21 DEFGENERIC.30 CALL-NEXT-METHOD.ERROR.1 + CALL-NEXT-METHOD.ERROR.2 DEFMETHOD.ERROR.14 DEFMETHOD.ERROR.15 + MAKE-CONDITION.3 MAKE-CONDITION.4 DELETE-PACKAGE.5 DELETE-PACKAGE.6 + MAP.48 TYPE-OF.1 TYPE-OF.4 CHAR-UPCASE.2 CHAR-DOWNCASE.2 + ENSURE-DIRECTORIES-EXIST.8 FRESH-LINE.5 PRINT.RANDOM-STATE.1 + PPRINT-FILL.14 PPRINT-FILL.15 PPRINT-LINEAR.14 PPRINT-TABULAR.13 + PPRINT-LOGICAL-BLOCK.17 PPRINT-POP.7 PPRINT-POP.8 + FORMAT.LOGICAL-BLOCK.CIRCLE.1 FORMAT.LOGICAL-BLOCK.CIRCLE.2 + FORMAT.LOGICAL-BLOCK.CIRCLE.3 FORMAT.JUSTIFY.30 FORMAT.JUSTIFY.32 + WITH-STANDARD-IO-SYNTAX.23 TRACE.8)) + +; prevent duplicate subclasses +; introduces PRINT.BACKQUOTE.RANDOM.14 +;r12391 781 +(doit r12391 :id dada + (REINITIALIZE-INSTANCE.ERROR.1 DEFGENERIC.ERROR.20 + DEFGENERIC.ERROR.21 DEFGENERIC.30 CALL-NEXT-METHOD.ERROR.1 + CALL-NEXT-METHOD.ERROR.2 DEFMETHOD.ERROR.14 DEFMETHOD.ERROR.15 + INVOKE-DEBUGGER.1 MAKE-CONDITION.3 MAKE-CONDITION.4 + DELETE-PACKAGE.5 DELETE-PACKAGE.6 MAP.48 TYPE-OF.1 TYPE-OF.4 + CHAR-UPCASE.2 CHAR-DOWNCASE.2 ENSURE-DIRECTORIES-EXIST.8 + FRESH-LINE.5 MAKE-BROADCAST-STREAM.8 PRINT.RANDOM-STATE.1 + PPRINT-FILL.14 PPRINT-FILL.15 PPRINT-LINEAR.14 PPRINT-TABULAR.13 + PPRINT-LOGICAL-BLOCK.17 PPRINT-POP.7 PPRINT-POP.8 + FORMAT.LOGICAL-BLOCK.CIRCLE.1 FORMAT.LOGICAL-BLOCK.CIRCLE.2 + FORMAT.LOGICAL-BLOCK.CIRCLE.3 FORMAT.JUSTIFY.30 FORMAT.JUSTIFY.32 + WITH-STANDARD-IO-SYNTAX.23)) + +(compileit r12391 :id dada + (REINITIALIZE-INSTANCE.ERROR.1 DEFGENERIC.ERROR.20 + DEFGENERIC.ERROR.21 DEFGENERIC.30 CALL-NEXT-METHOD.ERROR.1 + CALL-NEXT-METHOD.ERROR.2 DEFMETHOD.ERROR.14 DEFMETHOD.ERROR.15 + MAKE-CONDITION.3 MAKE-CONDITION.4 DELETE-PACKAGE.5 DELETE-PACKAGE.6 + MAP.48 TYPE-OF.1 TYPE-OF.4 CHAR-UPCASE.2 CHAR-DOWNCASE.2 + ENSURE-DIRECTORIES-EXIST.8 FRESH-LINE.5 MAKE-BROADCAST-STREAM.8 + PRINT.BACKQUOTE.RANDOM.14 PRINT.RANDOM-STATE.1 PPRINT-FILL.14 + PPRINT-FILL.15 PPRINT-LINEAR.14 PPRINT-TABULAR.13 + PPRINT-LOGICAL-BLOCK.17 PPRINT-POP.7 PPRINT-POP.8 + FORMAT.LOGICAL-BLOCK.CIRCLE.1 FORMAT.LOGICAL-BLOCK.CIRCLE.2 + FORMAT.LOGICAL-BLOCK.CIRCLE.3 FORMAT.JUSTIFY.30 FORMAT.JUSTIFY.32 + WITH-STANDARD-IO-SYNTAX.23 TRACE.8)) + +; change output-ugly-object +;r12390 780 +;doit nil +(compileit r12390 :id dada + (REINITIALIZE-INSTANCE.ERROR.1 DEFGENERIC.ERROR.20 + DEFGENERIC.ERROR.21 DEFGENERIC.30 CALL-NEXT-METHOD.ERROR.1 + CALL-NEXT-METHOD.ERROR.2 DEFMETHOD.ERROR.14 DEFMETHOD.ERROR.15 + MAKE-CONDITION.3 MAKE-CONDITION.4 DELETE-PACKAGE.5 DELETE-PACKAGE.6 + MAP.48 TYPE-OF.1 TYPE-OF.4 CHAR-UPCASE.2 CHAR-DOWNCASE.2 + ENSURE-DIRECTORIES-EXIST.8 FRESH-LINE.5 MAKE-BROADCAST-STREAM.8 + PRINT.RANDOM-STATE.1 PPRINT-FILL.14 PPRINT-FILL.15 PPRINT-LINEAR.14 + PPRINT-TABULAR.13 PPRINT-LOGICAL-BLOCK.17 PPRINT-POP.7 PPRINT-POP.8 + FORMAT.LOGICAL-BLOCK.CIRCLE.1 FORMAT.LOGICAL-BLOCK.CIRCLE.2 + FORMAT.LOGICAL-BLOCK.CIRCLE.3 FORMAT.JUSTIFY.30 FORMAT.JUSTIFY.32 + WITH-STANDARD-IO-SYNTAX.23 TRACE.8)) + +; changelogs for newest release +;r12383 779 +;doit nil +(compileit r12383 :id dada + (REINITIALIZE-INSTANCE.ERROR.1 DEFGENERIC.ERROR.20 + DEFGENERIC.ERROR.21 DEFGENERIC.30 CALL-NEXT-METHOD.ERROR.1 + CALL-NEXT-METHOD.ERROR.2 DEFMETHOD.ERROR.14 DEFMETHOD.ERROR.15 + MAKE-CONDITION.3 MAKE-CONDITION.4 DELETE-PACKAGE.5 DELETE-PACKAGE.6 + MAP.48 TYPE-OF.1 TYPE-OF.4 CHAR-UPCASE.2 CHAR-DOWNCASE.2 + ENSURE-DIRECTORIES-EXIST.8 FRESH-LINE.5 MAKE-BROADCAST-STREAM.8 + PRINT.RANDOM-STATE.1 PPRINT-FILL.14 PPRINT-FILL.15 PPRINT-LINEAR.14 + PPRINT-TABULAR.13 PPRINT-LOGICAL-BLOCK.17 PPRINT-POP.7 PPRINT-POP.8 + FORMAT.LOGICAL-BLOCK.CIRCLE.1 FORMAT.LOGICAL-BLOCK.CIRCLE.2 + FORMAT.LOGICAL-BLOCK.CIRCLE.3 FORMAT.JUSTIFY.30 FORMAT.JUSTIFY.32 + WITH-STANDARD-IO-SYNTAX.23 TRACE.8)) + +;abcl-src-0.18.0 +(doit 0.18.0 :id dada + (REINITIALIZE-INSTANCE.ERROR.1 DEFGENERIC.ERROR.20 + DEFGENERIC.ERROR.21 DEFGENERIC.30 CALL-NEXT-METHOD.ERROR.1 + CALL-NEXT-METHOD.ERROR.2 DEFMETHOD.ERROR.14 DEFMETHOD.ERROR.15 + MAKE-CONDITION.3 MAKE-CONDITION.4 DELETE-PACKAGE.5 + DELETE-PACKAGE.6 MAP.48 TYPE-OF.1 TYPE-OF.4 CHAR-UPCASE.2 + CHAR-DOWNCASE.2 ENSURE-DIRECTORIES-EXIST.8 FRESH-LINE.5 + MAKE-BROADCAST-STREAM.8 PRINT.RANDOM-STATE.1 PPRINT-FILL.14 + PPRINT-FILL.15 PPRINT-LINEAR.14 PPRINT-TABULAR.13 + PPRINT-LOGICAL-BLOCK.17 PPRINT-POP.7 PPRINT-POP.8 + FORMAT.LOGICAL-BLOCK.CIRCLE.1 FORMAT.LOGICAL-BLOCK.CIRCLE.2 + FORMAT.LOGICAL-BLOCK.CIRCLE.3 FORMAT.JUSTIFY.30 FORMAT.JUSTIFY.32 + WITH-STANDARD-IO-SYNTAX.23)) + +(compileit 0.18.0 :id dada + (REINITIALIZE-INSTANCE.ERROR.1 DEFGENERIC.ERROR.20 + DEFGENERIC.ERROR.21 DEFGENERIC.30 CALL-NEXT-METHOD.ERROR.1 + CALL-NEXT-METHOD.ERROR.2 DEFMETHOD.ERROR.14 DEFMETHOD.ERROR.15 + MAKE-CONDITION.3 MAKE-CONDITION.4 DELETE-PACKAGE.5 + DELETE-PACKAGE.6 MAP.48 TYPE-OF.1 TYPE-OF.4 CHAR-UPCASE.2 + CHAR-DOWNCASE.2 ENSURE-DIRECTORIES-EXIST.8 FRESH-LINE.5 + MAKE-BROADCAST-STREAM.8 PRINT.RANDOM-STATE.1 PPRINT-FILL.14 + PPRINT-FILL.15 PPRINT-LINEAR.14 PPRINT-TABULAR.13 + PPRINT-LOGICAL-BLOCK.17 PPRINT-POP.7 PPRINT-POP.8 + FORMAT.LOGICAL-BLOCK.CIRCLE.1 FORMAT.LOGICAL-BLOCK.CIRCLE.2 + FORMAT.LOGICAL-BLOCK.CIRCLE.3 FORMAT.JUSTIFY.30 FORMAT.JUSTIFY.32 + WITH-STANDARD-IO-SYNTAX.23 TRACE.8)) + +(doit 0.18.1 :id dada + (REINITIALIZE-INSTANCE.ERROR.1 DEFGENERIC.ERROR.20 + DEFGENERIC.ERROR.21 DEFGENERIC.30 CALL-NEXT-METHOD.ERROR.1 + CALL-NEXT-METHOD.ERROR.2 DEFMETHOD.ERROR.14 DEFMETHOD.ERROR.15 + MAKE-CONDITION.3 MAKE-CONDITION.4 DELETE-PACKAGE.5 + DELETE-PACKAGE.6 MAP.48 TYPE-OF.1 TYPE-OF.4 CHAR-UPCASE.2 + CHAR-DOWNCASE.2 ENSURE-DIRECTORIES-EXIST.8 FRESH-LINE.5 + MAKE-BROADCAST-STREAM.8 PRINT.BACKQUOTE.RANDOM.14 + PRINT.RANDOM-STATE.1 PPRINT-FILL.14 PPRINT-FILL.15 + PPRINT-LINEAR.14 PPRINT-TABULAR.13 PPRINT-LOGICAL-BLOCK.17 + PPRINT-POP.7 PPRINT-POP.8 FORMAT.LOGICAL-BLOCK.CIRCLE.1 + FORMAT.LOGICAL-BLOCK.CIRCLE.2 FORMAT.LOGICAL-BLOCK.CIRCLE.3 + FORMAT.JUSTIFY.30 FORMAT.JUSTIFY.32 + WITH-STANDARD-IO-SYNTAX.23)) + +(compileit 0.18.1 :id dada + (REINITIALIZE-INSTANCE.ERROR.1 DEFGENERIC.ERROR.20 + DEFGENERIC.ERROR.21 DEFGENERIC.30 CALL-NEXT-METHOD.ERROR.1 + CALL-NEXT-METHOD.ERROR.2 DEFMETHOD.ERROR.14 DEFMETHOD.ERROR.15 + MAKE-CONDITION.3 MAKE-CONDITION.4 DELETE-PACKAGE.5 + DELETE-PACKAGE.6 MAP.48 TYPE-OF.1 TYPE-OF.4 CHAR-UPCASE.2 + CHAR-DOWNCASE.2 ENSURE-DIRECTORIES-EXIST.8 FRESH-LINE.5 + MAKE-BROADCAST-STREAM.8 PRINT.BACKQUOTE.RANDOM.14 + PRINT.RANDOM-STATE.1 PPRINT-FILL.14 PPRINT-FILL.15 + PPRINT-LINEAR.14 PPRINT-TABULAR.13 PPRINT-LOGICAL-BLOCK.17 + PPRINT-POP.7 PPRINT-POP.8 FORMAT.LOGICAL-BLOCK.CIRCLE.1 + FORMAT.LOGICAL-BLOCK.CIRCLE.2 FORMAT.LOGICAL-BLOCK.CIRCLE.3 + FORMAT.JUSTIFY.30 FORMAT.JUSTIFY.32 WITH-STANDARD-IO-SYNTAX.23 + TRACE.8)) + +(doit r12506 :id jupiter + :uname "i386-pc-solaris2.11" :jvm "jdk-1.6.0_13" + (REINITIALIZE-INSTANCE.ERROR.1 DEFGENERIC.ERROR.20 + DEFGENERIC.ERROR.21 DEFGENERIC.30 CALL-NEXT-METHOD.ERROR.1 + CALL-NEXT-METHOD.ERROR.2 DEFMETHOD.ERROR.14 DEFMETHOD.ERROR.15 + INVOKE-DEBUGGER.1 MAKE-CONDITION.3 MAKE-CONDITION.4 + DELETE-PACKAGE.5 DELETE-PACKAGE.6 MAP.48 TYPE-OF.1 TYPE-OF.4 + CHAR-UPCASE.2 CHAR-DOWNCASE.2 FRESH-LINE.5 PRINT.RANDOM-STATE.1 + PPRINT-FILL.14 PPRINT-FILL.15 PPRINT-LINEAR.14 PPRINT-TABULAR.13 + PPRINT-LOGICAL-BLOCK.17 PPRINT-POP.7 PPRINT-POP.8 + FORMAT.LOGICAL-BLOCK.CIRCLE.1 FORMAT.LOGICAL-BLOCK.CIRCLE.2 + FORMAT.LOGICAL-BLOCK.CIRCLE.3 FORMAT.JUSTIFY.30 FORMAT.JUSTIFY.32 + WITH-STANDARD-IO-SYNTAX.23)) + +(compileit r12506 :id jupiter + (REINITIALIZE-INSTANCE.ERROR.1 DEFGENERIC.ERROR.20 + DEFGENERIC.ERROR.21 DEFGENERIC.30 CALL-NEXT-METHOD.ERROR.1 + CALL-NEXT-METHOD.ERROR.2 DEFMETHOD.ERROR.14 DEFMETHOD.ERROR.15 + INVOKE-DEBUGGER.1 MAKE-CONDITION.3 MAKE-CONDITION.4 + DELETE-PACKAGE.5 DELETE-PACKAGE.6 MAP.48 TYPE-OF.1 TYPE-OF.4 + CHAR-UPCASE.2 CHAR-DOWNCASE.2 ENSURE-DIRECTORIES-EXIST.8 + FRESH-LINE.5 PRINT.RANDOM-STATE.1 PPRINT-FILL.14 PPRINT-FILL.15 + PPRINT-LINEAR.14 PPRINT-TABULAR.13 PPRINT-LOGICAL-BLOCK.17 + PPRINT-POP.7 PPRINT-POP.8 FORMAT.LOGICAL-BLOCK.CIRCLE.1 + FORMAT.LOGICAL-BLOCK.CIRCLE.2 FORMAT.LOGICAL-BLOCK.CIRCLE.3 + FORMAT.JUSTIFY.30 FORMAT.JUSTIFY.32 WITH-STANDARD-IO-SYNTAX.23 + TRACE.8)) \ No newline at end of file Modified: trunk/abcl/test/lisp/ansi/package.lisp ============================================================================== --- trunk/abcl/test/lisp/ansi/package.lisp (original) +++ trunk/abcl/test/lisp/ansi/package.lisp Sat Feb 27 02:01:01 2010 @@ -1,7 +1,7 @@ (defpackage :abcl.test.ansi (:use :cl :asdf) (:nicknames "ansi-tests" "abcl-ansi-tests" "gcl-ansi") - (:export :run)) + (:export :run :report :parse)) (in-package :abcl.test.ansi) 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 Sat Feb 27 02:01:01 2010 @@ -1,5 +1,7 @@ ;;;; $Id$ -;;;; Parse ANSI test list +;;;; +;;;; Parse ANSI test results from a s-expr database, allowing queries +;;;; to show differences. ;;;; ;;;; 'cuz I get lost after comparing about five items in a list ;;;; @@ -8,9 +10,13 @@ To use -1. create a "database" of test results consisting of S-exp of form +1. Create a "database" of test results consisting of s-exps. A + default database is in 'failures'. + + The s-exprs have the form: - (compileit|doit ()) + (compileit|doit :id [: ] + ()) where @@ -18,61 +24,130 @@ whether the compiled or interpreted tests were run. version A symbol identifying the version of source of the - tests. + tests (i.e. r12506 or 0.18.0) + + :id is a symbol identifying the environment for + the tests + + :key Additional key-value pairs The list of symbols failing the tests. -An example: +An example on an entry: -(compileit 0.18.1 (REINITIALIZE-INSTANCE.ERROR.1 DEFGENERIC.ERROR.20 -DEFGENERIC.ERROR.21 DEFGENERIC.30 CALL-NEXT-METHOD.ERROR.1 -CALL-NEXT-METHOD.ERROR.2 DEFMETHOD.ERROR.14 DEFMETHOD.ERROR.15 -MAKE-CONDITION.3 MAKE-CONDITION.4 DELETE-PACKAGE.5 DELETE-PACKAGE.6 -MAP.48 TYPE-OF.1 TYPE-OF.4 CHAR-UPCASE.2 CHAR-DOWNCASE.2 -ENSURE-DIRECTORIES-EXIST.8 FRESH-LINE.5 MAKE-BROADCAST-STREAM.8 -PRINT.BACKQUOTE.RANDOM.14 PRINT.RANDOM-STATE.1 PPRINT-FILL.14 -PPRINT-FILL.15 PPRINT-LINEAR.14 PPRINT-TABULAR.13 -PPRINT-LOGICAL-BLOCK.17 PPRINT-POP.7 PPRINT-POP.8 -FORMAT.LOGICAL-BLOCK.CIRCLE.1 FORMAT.LOGICAL-BLOCK.CIRCLE.2 -FORMAT.LOGICAL-BLOCK.CIRCLE.3 FORMAT.JUSTIFY.30 FORMAT.JUSTIFY.32 -WITH-STANDARD-IO-SYNTAX.23 TRACE.8)). + (doit r12506 :id jupiter + :uname "i386-pc-solaris2.11" :jvm "jdk-1.6.0_13" + (REINITIALIZE-INSTANCE.ERROR.1 DEFGENERIC.ERROR.20 + DEFGENERIC.ERROR.21 DEFGENERIC.30 CALL-NEXT-METHOD.ERROR.1 + CALL-NEXT-METHOD.ERROR.2 DEFMETHOD.ERROR.14 DEFMETHOD.ERROR.15 + INVOKE-DEBUGGER.1 MAKE-CONDITION.3 MAKE-CONDITION.4 + DELETE-PACKAGE.5 DELETE-PACKAGE.6 MAP.48 TYPE-OF.1 TYPE-OF.4 + CHAR-UPCASE.2 CHAR-DOWNCASE.2 FRESH-LINE.5 PRINT.RANDOM-STATE.1 + PPRINT-FILL.14 PPRINT-FILL.15 PPRINT-LINEAR.14 PPRINT-TABULAR.13 + PPRINT-LOGICAL-BLOCK.17 PPRINT-POP.7 PPRINT-POP.8 + FORMAT.LOGICAL-BLOCK.CIRCLE.1 FORMAT.LOGICAL-BLOCK.CIRCLE.2 + FORMAT.LOGICAL-BLOCK.CIRCLE.3 FORMAT.JUSTIFY.30 FORMAT.JUSTIFY.32 + WITH-STANDARD-IO-SYNTAX.23)) -2. Run (PARSE ) on the file of your database. +2. Run (PARSE []) on the file of your database. Without an + argument, the default database is read. -3. Then differences between versions can be queried via DIFFERENCE +3. Then differences between versions can be queried via REPORT - CL-USER> (difference 'compileit '0.18.0 'r13590) + CL-USER> (REPORT 'compileit '0.18.0 'r13590) |# +(in-package :abcl.test.ansi) + (defvar *doit* (make-hash-table)) (defvar *compileit* (make-hash-table)) +(defvar *id* (make-hash-table)) + +(defun reset () + (clrhash *doit*) + (clrhash *compileit*) + (clrhash *id*)) (defun get-hash-table (test) (getf `(doit ,*doit* compileit ,*compileit*) test)) -(defun parse (&optional (file #p"failures") +(defvar *default-database-file* + (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*) (with-open-file (s file :direction :input) (do ((form (read s) (read s nil nil))) ((null form)) - (destructuring-bind (test version failures) form - (setf (gethash version - (get-hash-table test)) - failures))))) + (destructuring-bind (test version &rest rest) form + (let ((args) (failures) (id)) + (dolist (arg rest) + (if (typep arg 'cons) + (setf failures arg) + (push arg args))) + (setf args (nreverse args)) + (unless (getf args :id) + (push 'noid args) + (push :id args)) + (setf id (getf args :id)) + (if (> (length args) 2) + (setf (gethash id *id*) args) + (if (null (gethash id *id*)) + (setf (gethash id *id*) args))) + (when (null (gethash version (get-hash-table test))) + (setf (gethash version (get-hash-table test)) + (make-hash-table))) + (setf (gethash id + (gethash version (get-hash-table test))) + failures)))))) (defun versions (test) (loop :for key :being :the :hash-keys :of (get-hash-table test) :collecting key)) -(defun difference (test version-1 version-2) - (let ((failures-1 (gethash version-1 (get-hash-table test))) - (failures-2 (gethash version-2 (get-hash-table test)))) - (format t "~A: ~A failures~% ~A~%" - version-1 (length failures-1) (set-difference failures-1 failures-2)) - (format t "~A: ~A failures~% ~A~%" - version-2 (length failures-2) (set-difference failures-2 failures-1))) +(defun report-versions (&optional (test 'compileit)) + (format t "~A has the following versions:~%~A~%" + test (versions test)) (values)) + +(defun get-failures (test version) + (gethash version (get-hash-table test))) + +(defun difference (failures-1 failures-2) + (list + (list (length failures-1) + (set-difference failures-1 failures-2)) + (list (length failures-2) + (set-difference failures-2 failures-1)))) + +(defun generate-report (test version-1 version-2) + (flet ((list-results (hash-table) + (loop + :for key :being :the :hash-key :of hash-table + :using (:hash-value value) + :collecting (list key value)))) + (let ((entries-1 (list-results (get-failures test version-1))) + (entries-2 (list-results (get-failures test version-2)))) + (loop :for (id-1 failure-1) :in entries-1 + :appending (loop :for (id-2 failure-2) :in entries-2 + :collecting (list (cons id-1 id-2) + (difference failure-1 + failure-2))))))) + +(defun report (test version-1 version-2) + (let ((reports (generate-report test version-1 version-2))) + (dolist (report reports) + (destructuring-bind ((id1 . id2) ((total-failures1 diff-1->2) + (total-failures2 diff-2->1))) + report + (when diff-1->2 + (format t "~A[~A] --> ~A[~A] additional failures:~%~A~%" + version-1 id1 version-2 id2 diff-1->2)) + (when diff-2->1 + (format t "~A[~A] --> ~A[~A] additional failures:~%~A~%" + version-2 id2 version-1 id1 diff-2->1)))))) From vvoutilainen at common-lisp.net Sat Feb 27 19:31:48 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sat, 27 Feb 2010 14:31:48 -0500 Subject: [armedbear-cvs] r12510 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sat Feb 27 14:31:45 2010 New Revision: 12510 Log: Fix the test WITH-STANDARD-IO-SYNTAX.23, which was failing because our with-standard-io-syntax implementation failed to restore *print-pprint-dispatch* to its standard value. Patch by Douglas R. Miles, kudos for finding the cause. Modified: trunk/abcl/src/org/armedbear/lisp/with-standard-io-syntax.lisp Modified: trunk/abcl/src/org/armedbear/lisp/with-standard-io-syntax.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/with-standard-io-syntax.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/with-standard-io-syntax.lisp Sat Feb 27 14:31:45 2010 @@ -45,6 +45,7 @@ (*print-level* nil) (*print-lines* nil) (*print-miser-width* nil) + (*print-pprint-dispatch* (copy-pprint-dispatch nil)) (*print-pretty* nil) (*print-radix* nil) (*print-readably* t) From vvoutilainen at common-lisp.net Sun Feb 28 14:27:13 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 28 Feb 2010 09:27:13 -0500 Subject: [armedbear-cvs] r12511 - trunk/abcl Message-ID: Author: vvoutilainen Date: Sun Feb 28 09:27:10 2010 New Revision: 12511 Log: Add a changelog entry for the with-standard-io-syntax bugfix. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Sun Feb 28 09:27:10 2010 @@ -47,6 +47,10 @@ Fixes/Optimizations ------------------- +* [svn r12510] The new ansi-test WITH-STANDARD-IO-SYNTAX.23 passes. + Our with-standard-io-syntax implementation now correctly resets all necessary + pprint variables. Patch by Douglas R. Miles, thanks for the contribution! + * [svn r12485] Pathnames starting with "." can now have TYPE. * [svn r12484] FASLs containing "." characters not used to indicate From vvoutilainen at common-lisp.net Sun Feb 28 15:54:19 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 28 Feb 2010 10:54:19 -0500 Subject: [armedbear-cvs] r12512 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Feb 28 10:54:17 2010 New Revision: 12512 Log: Make Condition.writeToString() final, add documentation to Condition.getMessage(), fix remaining overrides of Condition.writeToString() to override Condition.getMessage() instead. Modified: trunk/abcl/src/org/armedbear/lisp/CellError.java trunk/abcl/src/org/armedbear/lisp/Condition.java trunk/abcl/src/org/armedbear/lisp/EndOfFile.java Modified: trunk/abcl/src/org/armedbear/lisp/CellError.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/CellError.java (original) +++ trunk/abcl/src/org/armedbear/lisp/CellError.java Sun Feb 28 10:54:17 2010 @@ -98,10 +98,10 @@ } @Override - public String writeToString() + public String getMessage() { if (Symbol.PRINT_ESCAPE.symbolValue() == NIL) - return super.writeToString(); + return super.getMessage(); StringBuffer sb = new StringBuffer(typeOf().writeToString()); sb.append(' '); sb.append(getCellName().writeToString()); Modified: trunk/abcl/src/org/armedbear/lisp/Condition.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Condition.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Condition.java Sun Feb 28 10:54:17 2010 @@ -129,9 +129,13 @@ setInstanceSlotValue(Symbol.FORMAT_ARGUMENTS, formatArguments); } + /** + * Extending classes should override this method if they want to + * customize how they will be printed. + */ public String getMessage() { - return message; + return getFormatControl().toString(); } @Override @@ -176,7 +180,7 @@ } @Override - public String writeToString() + public final String writeToString() { final LispThread thread = LispThread.currentThread(); if (Symbol.PRINT_ESCAPE.symbolValue(thread) == NIL) Modified: trunk/abcl/src/org/armedbear/lisp/EndOfFile.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/EndOfFile.java (original) +++ trunk/abcl/src/org/armedbear/lisp/EndOfFile.java Sun Feb 28 10:54:17 2010 @@ -72,7 +72,7 @@ } @Override - public String writeToString() + public String getMessage() { return unreadableString(Symbol.END_OF_FILE); }