From ehuelsmann at common-lisp.net Sat Jan 1 11:52:27 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 01 Jan 2011 06:52:27 -0500 Subject: [armedbear-cvs] r13114 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jan 1 06:52:26 2011 New Revision: 13114 Log: Register each node being created with its parent. A parent is always part of the same compiland. 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 Sat Jan 1 06:52:26 2011 @@ -389,10 +389,19 @@ (defstruct node form + children (compiland *current-compiland*)) ;; No need for a special constructor: nobody instantiates ;; nodes directly +(declaim (inline add-node-child)) +(defun add-node-child (parent child) + "Add a child node to the `children` list of a parent node, +if that parent belongs to the same compiland." + (when parent + (when (eq (node-compiland parent) *current-compiland*) + (push child (node-children parent))))) + ;; control-transferring blocks: TAGBODY, CATCH, to do: BLOCK (defstruct (control-transferring-node (:include node)) @@ -418,6 +427,7 @@ (defun make-tagbody-node () (let ((block (%make-tagbody-node))) (push block (compiland-blocks *current-compiland*)) + (add-node-child (car *blocks*) block) block)) (defstruct (catch-node (:conc-name catch-) @@ -430,6 +440,7 @@ (defun make-catch-node () (let ((block (%make-catch-node))) (push block (compiland-blocks *current-compiland*)) + (add-node-child (car *blocks*) block) block)) (defstruct (block-node (:conc-name block-) @@ -447,6 +458,7 @@ (defun make-block-node (name) (let ((block (%make-block-node name))) (push block (compiland-blocks *current-compiland*)) + (add-node-child (car *blocks*) block) block)) ;; binding blocks: LET, LET*, FLET, LABELS, M-V-B, PROGV, LOCALLY @@ -470,6 +482,7 @@ (defun make-let/let*-node () (let ((block (%make-let/let*-node))) (push block (compiland-blocks *current-compiland*)) + (add-node-child (car *blocks*) block) block)) (defstruct (flet-node (:conc-name flet-) @@ -479,6 +492,7 @@ (defun make-flet-node () (let ((block (%make-flet-node))) (push block (compiland-blocks *current-compiland*)) + (add-node-child (car *blocks*) block) block)) (defstruct (labels-node (:conc-name labels-) @@ -488,6 +502,7 @@ (defun make-labels-node () (let ((block (%make-labels-node))) (push block (compiland-blocks *current-compiland*)) + (add-node-child (car *blocks*) block) block)) (defstruct (m-v-b-node (:conc-name m-v-b-) @@ -497,6 +512,7 @@ (defun make-m-v-b-node () (let ((block (%make-m-v-b-node))) (push block (compiland-blocks *current-compiland*)) + (add-node-child (car *blocks*) block) block)) (defstruct (progv-node (:conc-name progv-) @@ -515,6 +531,7 @@ (defun make-locally-node () (let ((block (%make-locally-node))) (push block (compiland-blocks *current-compiland*)) + (add-node-child (car *blocks*) block) block)) ;; blocks requiring non-local exits: UNWIND-PROTECT, SYS:SYNCHRONIZED-ON @@ -525,6 +542,7 @@ (defun make-protected-node () (let ((block (%make-protected-node))) (push block (compiland-blocks *current-compiland*)) + (add-node-child (car *blocks*) block) block)) (defstruct (unwind-protect-node (:conc-name unwind-protect-) @@ -534,6 +552,7 @@ (defun make-unwind-protect-node () (let ((block (%make-unwind-protect-node))) (push block (compiland-blocks *current-compiland*)) + (add-node-child (car *blocks*) block) block)) (defstruct (synchronized-node (:conc-name synchronized-) @@ -543,6 +562,7 @@ (defun make-synchronized-node () (let ((block (%make-synchronized-node))) (push block (compiland-blocks *current-compiland*)) + (add-node-child (car *blocks*) block) block)) From ehuelsmann at common-lisp.net Sat Jan 1 12:07:45 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 01 Jan 2011 07:07:45 -0500 Subject: [armedbear-cvs] r13115 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jan 1 07:07:44 2011 New Revision: 13115 Log: Add SOME-NESTED-BLOCK function to work with hierarchical block structures. 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 Sat Jan 1 07:07:44 2011 @@ -574,6 +574,14 @@ (eq name (block-name block))) (return block)))) +(defun some-nested-block (block predicate) + "Applies `predicate` recursively to the children of `block`, +until predicate returns non-NIL, returning that value." + (some #'(lambda (b) + (or (funcall predicate b) + (some-nested-block b predicate))) + (node-children block))) + (defknown node-constant-p (t) boolean) (defun node-constant-p (object) (cond ((node-p object) From ehuelsmann at common-lisp.net Sat Jan 1 14:53:38 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 01 Jan 2011 09:53:38 -0500 Subject: [armedbear-cvs] r13116 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jan 1 09:53:38 2011 New Revision: 13116 Log: Remove layering violation from compiler-pass2::p2-setq; there should be no macroexpansion or precompiler calls: that's pass1. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Jan 1 09:53:38 2011 @@ -6075,13 +6075,7 @@ (defknown p2-setq (t t t) t) (defun p2-setq (form target representation) (unless (= (length form) 3) - (return-from p2-setq (compile-form (precompiler:precompile-form form t - *compile-file-environment*) - target representation))) - (let ((expansion (macroexpand (%cadr form) *compile-file-environment*))) - (unless (eq expansion (%cadr form)) - (compile-form (list 'SETF expansion (%caddr form)) target representation) - (return-from p2-setq))) + (assert (not "p2-setq should receive exactly 2 arguments!"))) (let* ((name (%cadr form)) (variable (find-visible-variable name)) (value-form (%caddr form))) From ehuelsmann at common-lisp.net Sat Jan 1 17:41:45 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 01 Jan 2011 12:41:45 -0500 Subject: [armedbear-cvs] r13117 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jan 1 12:41:38 2011 New Revision: 13117 Log: Fix #117: Workaround for the fact that we shouldn't be doing UNSAFE-P checks in pass1. 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 Sat Jan 1 12:41:38 2011 @@ -1186,8 +1186,8 @@ (case (%car args) (QUOTE nil) - (LAMBDA - nil) +;; (LAMBDA +;; nil) ((RETURN-FROM GO CATCH THROW UNWIND-PROTECT BLOCK) t) (t From ehuelsmann at common-lisp.net Sat Jan 1 23:36:07 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 01 Jan 2011 18:36:07 -0500 Subject: [armedbear-cvs] r13118 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jan 1 18:36:06 2011 New Revision: 13118 Log: Put the transformed INITFORM back into form being transformed. 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 Sat Jan 1 18:36:06 2011 @@ -434,6 +434,8 @@ (,var (make-variable :name (check-name ,name) :initform ,initform :block ,block))) + (when (neq ,initform (cadr ,varspec)) + (setf (cadr ,varspec) ,initform)) (push ,var ,variables-var) , at body1)) (t From ehuelsmann at common-lisp.net Sun Jan 2 20:27:25 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 02 Jan 2011 15:27:25 -0500 Subject: [armedbear-cvs] r13119 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 2 15:27:23 2011 New Revision: 13119 Log: Fix ANSI-TEST regressions from r13096: Arrays with an element-type of NIL can't store anything, not even NIL, because the type of NIL is NULL. Modified: trunk/abcl/src/org/armedbear/lisp/make_array.java 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 Sun Jan 2 15:27:23 2011 @@ -183,7 +183,7 @@ else if (upgradedType == NIL) { v = new NilVector(size); - defaultInitialElement = NIL; + defaultInitialElement = null; } else { @@ -219,7 +219,8 @@ } else { - v.fill(defaultInitialElement); + if (defaultInitialElement != null) + v.fill(defaultInitialElement); } if (fillPointer != NIL) v.setFillPointer(fillPointer); From ehuelsmann at common-lisp.net Mon Jan 3 12:09:41 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 03 Jan 2011 07:09:41 -0500 Subject: [armedbear-cvs] r13120 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jan 3 07:09:37 2011 New Revision: 13120 Log: Improve parent/child block relationship tracking; Improve block-finding; Untabify (sorry to mix that!). 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 Mon Jan 3 07:09:37 2011 @@ -371,7 +371,7 @@ ;; which itself isn't being compiled (references-allowed-p t) ;;whether a reference to the function CAN be captured (references-needed-p nil) ;;whether a reference to the function NEEDS to be - ;;captured, because the function name is used in a + ;;captured, because the function name is used in a ;;(function ...) form. Obviously implies ;;references-allowed-p. ) @@ -387,6 +387,17 @@ (defvar *using-arg-array* nil) (defvar *hairy-arglist-p* nil) + +(defvar *block* nil + "The innermost block applicable to the current lexical environment.") +(defvar *blocks* () + "The list of blocks in effect in the current lexical environment. + +The top node does not need to be equal to the value of `*block*`. E.g. +when processing the bindings of a LET form, `*block*` is bound to the node +of that LET, while the block is not considered 'in effect': that only happens +until the body is being processed.") + (defstruct node form children @@ -415,7 +426,7 @@ (defstruct (tagbody-node (:conc-name tagbody-) (:include control-transferring-node) - (:constructor %make-tagbody-node ())) + (:constructor %make-tagbody-node ())) ;; True if a tag in this tagbody is the target of a non-local GO. non-local-go-p ;; Tags in the tagbody form; a list of tag structures @@ -427,12 +438,12 @@ (defun make-tagbody-node () (let ((block (%make-tagbody-node))) (push block (compiland-blocks *current-compiland*)) - (add-node-child (car *blocks*) block) + (add-node-child *block* block) block)) (defstruct (catch-node (:conc-name catch-) (:include control-transferring-node) - (:constructor %make-catch-node ())) + (:constructor %make-catch-node ())) ;; The catch tag-form is evaluated, meaning we ;; have no predefined value to store here ) @@ -440,7 +451,7 @@ (defun make-catch-node () (let ((block (%make-catch-node))) (push block (compiland-blocks *current-compiland*)) - (add-node-child (car *blocks*) block) + (add-node-child *block* block) block)) (defstruct (block-node (:conc-name block-) @@ -458,7 +469,7 @@ (defun make-block-node (name) (let ((block (%make-block-node name))) (push block (compiland-blocks *current-compiland*)) - (add-node-child (car *blocks*) block) + (add-node-child *block* block) block)) ;; binding blocks: LET, LET*, FLET, LABELS, M-V-B, PROGV, LOCALLY @@ -477,47 +488,47 @@ (defstruct (let/let*-node (:conc-name let-) (:include binding-node) - (:constructor %make-let/let*-node ()))) + (:constructor %make-let/let*-node ()))) (defknown make-let/let*-node () t) (defun make-let/let*-node () (let ((block (%make-let/let*-node))) (push block (compiland-blocks *current-compiland*)) - (add-node-child (car *blocks*) block) + (add-node-child *block* block) block)) (defstruct (flet-node (:conc-name flet-) (:include binding-node) - (:constructor %make-flet-node ()))) + (:constructor %make-flet-node ()))) (defknown make-flet-node () t) (defun make-flet-node () (let ((block (%make-flet-node))) (push block (compiland-blocks *current-compiland*)) - (add-node-child (car *blocks*) block) + (add-node-child *block* block) block)) (defstruct (labels-node (:conc-name labels-) (:include binding-node) - (:constructor %make-labels-node ()))) + (:constructor %make-labels-node ()))) (defknown make-labels-node () t) (defun make-labels-node () (let ((block (%make-labels-node))) (push block (compiland-blocks *current-compiland*)) - (add-node-child (car *blocks*) block) + (add-node-child *block* block) block)) (defstruct (m-v-b-node (:conc-name m-v-b-) (:include binding-node) - (:constructor %make-m-v-b-node ()))) + (:constructor %make-m-v-b-node ()))) (defknown make-m-v-b-node () t) (defun make-m-v-b-node () (let ((block (%make-m-v-b-node))) (push block (compiland-blocks *current-compiland*)) - (add-node-child (car *blocks*) block) + (add-node-child *block* block) block)) (defstruct (progv-node (:conc-name progv-) (:include binding-node) - (:constructor %make-progv-node ()))) + (:constructor %make-progv-node ()))) (defknown make-progv-node () t) (defun make-progv-node () (let ((block (%make-progv-node))) @@ -526,61 +537,95 @@ (defstruct (locally-node (:conc-name locally-) (:include binding-node) - (:constructor %make-locally-node ()))) + (:constructor %make-locally-node ()))) (defknown make-locally-node () t) (defun make-locally-node () (let ((block (%make-locally-node))) (push block (compiland-blocks *current-compiland*)) - (add-node-child (car *blocks*) block) + (add-node-child *block* block) block)) ;; blocks requiring non-local exits: UNWIND-PROTECT, SYS:SYNCHRONIZED-ON (defstruct (protected-node (:include node) - (:constructor %make-protected-node ()))) + (:constructor %make-protected-node ()))) (defknown make-protected-node () t) (defun make-protected-node () (let ((block (%make-protected-node))) (push block (compiland-blocks *current-compiland*)) - (add-node-child (car *blocks*) block) + (add-node-child *block* block) block)) (defstruct (unwind-protect-node (:conc-name unwind-protect-) (:include protected-node) - (:constructor %make-unwind-protect-node ()))) + (:constructor %make-unwind-protect-node ()))) (defknown make-unwind-protect-node () t) (defun make-unwind-protect-node () (let ((block (%make-unwind-protect-node))) (push block (compiland-blocks *current-compiland*)) - (add-node-child (car *blocks*) block) + (add-node-child *block* block) block)) (defstruct (synchronized-node (:conc-name synchronized-) (:include protected-node) - (:constructor %make-synchronized-node ()))) + (:constructor %make-synchronized-node ()))) (defknown make-synchronized-node () t) (defun make-synchronized-node () (let ((block (%make-synchronized-node))) (push block (compiland-blocks *current-compiland*)) - (add-node-child (car *blocks*) block) + (add-node-child *block* block) block)) - -(defvar *blocks* ()) - (defun find-block (name) (dolist (block *blocks*) (when (and (block-node-p block) (eq name (block-name block))) (return block)))) -(defun some-nested-block (block predicate) - "Applies `predicate` recursively to the children of `block`, -until predicate returns non-NIL, returning that value." - (some #'(lambda (b) - (or (funcall predicate b) - (some-nested-block b predicate))) - (node-children block))) +(defun %find-enclosed-blocks (form) + "Helper function for `find-enclosed-blocks`, implementing the actual +algorithm specified there." + (cond + ((node-p form) (list form)) + ((atom form) nil) + (t + ;; We can't use MAPCAN or DOLIST here: they'll choke on dotted lists + (do* ((tail form (cdr tail)) + blocks) + ((null tail) blocks) + (setf blocks + (nconc (%find-enclosed-blocks (if (consp tail) + (car tail) tail)) + blocks)) + (when (not (listp tail)) + (return blocks)))))) + +(defun find-enclosed-blocks (form) + "Returns the immediate enclosed blocks by searching the form's subforms. + +More deeply nested blocks can be reached through the `node-children` +field of the immediate enclosed blocks." + (when *blocks* + ;; when the innermost enclosing block doesn't have node-children, + ;; there's really nothing to search for. + (when (null (node-children (car *blocks*))) + (return-from find-enclosed-blocks))) + + (%find-enclosed-blocks form)) + + +(defun some-nested-block (predicate blocks) + "Applies `predicate` recursively to the `blocks` and its children, +until predicate returns non-NIL, returning that value. + +`blocks` may be a single block or a list of blocks." + (when blocks + (some #'(lambda (b) + (or (funcall predicate b) + (some-nested-block predicate (node-children b)))) + (if (listp blocks) + blocks + (list blocks))))) (defknown node-constant-p (t) boolean) (defun node-constant-p (object) @@ -605,6 +650,11 @@ (catch-node-p object) (synchronized-node-p object))) +(defun block-opstack-unsafe-p (block) + (or (when (tagbody-node-p block) (tagbody-non-local-go-p block)) + (when (block-node-p block) (block-non-local-return-p block)) + (catch-node-p block))) + (defknown block-creates-runtime-bindings-p (t) boolean) (defun block-creates-runtime-bindings-p (block) ;; FIXME: This may be false, if the bindings to be From ehuelsmann at common-lisp.net Mon Jan 3 13:29:07 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 03 Jan 2011 08:29:07 -0500 Subject: [armedbear-cvs] r13121 - branches/unsafe-p-removal Message-ID: Author: ehuelsmann Date: Mon Jan 3 08:29:06 2011 New Revision: 13121 Log: Create unsafe-p removal branch to commit my work in progress while the release process wants a stable trunk. Added: branches/unsafe-p-removal/ - copied from r13120, /trunk/ From ehuelsmann at common-lisp.net Mon Jan 3 20:30:16 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 03 Jan 2011 15:30:16 -0500 Subject: [armedbear-cvs] r13122 - branches/unsafe-p-removal/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jan 3 15:30:12 2011 New Revision: 13122 Log: Remove REWRITE-RETURN-FROM, REWRITE-PROGV and REWRITE-THROW in favor of unsafety detection in compilation pass2. Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Mon Jan 3 15:30:12 2011 @@ -468,6 +468,7 @@ (declare (type cons form)) (let* ((*visible-variables* *visible-variables*) (block (make-let/let*-node)) + (*block* block) (op (%car form)) (varlist (cadr form)) (body (cddr form))) @@ -506,6 +507,7 @@ (defun p1-locally (form) (let* ((*visible-variables* *visible-variables*) (block (make-locally-node)) + (*block* block) (free-specials (process-declarations-for-vars (cdr form) nil block))) (setf (locally-free-specials block) free-specials) (dolist (special free-specials) @@ -523,6 +525,7 @@ (return-from p1-m-v-b (p1-let/let* new-form)))) (let* ((*visible-variables* *visible-variables*) (block (make-m-v-b-node)) + (*block* block) (varlist (cadr form)) ;; Process the values-form first. ("The scopes of the name binding and ;; declarations do not include the values-form.") @@ -552,6 +555,7 @@ (defun p1-block (form) (let* ((block (make-block-node (cadr form))) + (*block* block) (*blocks* (cons block *blocks*))) (setf (cddr form) (p1-body (cddr form))) (setf (block-form block) form) @@ -568,6 +572,7 @@ (let* ((tag (p1 (cadr form))) (body (cddr form)) (block (make-catch-node)) + (*block* block) ;; our subform processors need to know ;; they're enclosed in a CATCH block (*blocks* (cons block *blocks*)) @@ -591,6 +596,7 @@ (let* ((synchronized-object (p1 (cadr form))) (body (cddr form)) (block (make-synchronized-node)) + (*block* block) (*blocks* (cons block *blocks*)) result) (dolist (subform body) @@ -614,6 +620,7 @@ ;; However, p1 transforms the forms being processed, so, we ;; need to copy the forms to create a second copy. (let* ((block (make-unwind-protect-node)) + (*block* block) ;; a bit of jumping through hoops... (unwinding-forms (p1-body (copy-tree (cddr form)))) (unprotected-forms (p1-body (cddr form))) @@ -629,9 +636,6 @@ (defknown p1-return-from (t) t) (defun p1-return-from (form) - (let ((new-form (rewrite-return-from form))) - (when (neq form new-form) - (return-from p1-return-from (p1 new-form)))) (let* ((name (second form)) (block (find-block name))) (when (null block) @@ -661,6 +665,7 @@ (defun p1-tagbody (form) (let* ((block (make-tagbody-node)) + (*block* block) (*blocks* (cons block *blocks*)) (*visible-tags* *visible-tags*) (local-tags '()) @@ -927,6 +932,7 @@ ((with-saved-compiler-policy (process-optimization-declarations (cddr form)) (let* ((block (make-flet-node)) + (*block* block) (*blocks* (cons block *blocks*)) (body (cddr form)) (*visible-variables* *visible-variables*)) @@ -965,6 +971,7 @@ (*current-compiland* (local-function-compiland local-function))) (p1-compiland (local-function-compiland local-function)))) (let* ((block (make-labels-node)) + (*block* block) (*blocks* (cons block *blocks*)) (body (cddr form)) (*visible-variables* *visible-variables*)) @@ -1068,13 +1075,10 @@ (defknown p1-progv (t) t) (defun p1-progv (form) ;; We've already checked argument count in PRECOMPILE-PROGV. - - (let ((new-form (rewrite-progv form))) - (when (neq new-form form) - (return-from p1-progv (p1 new-form)))) (let* ((symbols-form (p1 (cadr form))) (values-form (p1 (caddr form))) (block (make-progv-node)) + (*block* block) (*blocks* (cons block *blocks*)) (body (cdddr form))) ;; The (commented out) block below means to detect compile-time @@ -1090,20 +1094,6 @@ `(progv ,symbols-form ,values-form ,@(p1-body body))) block)) -(defknown rewrite-progv (t) t) -(defun rewrite-progv (form) - (let ((symbols-form (cadr form)) - (values-form (caddr form)) - (body (cdddr form))) - (cond ((or (unsafe-p symbols-form) (unsafe-p values-form)) - (let ((g1 (gensym)) - (g2 (gensym))) - `(let ((,g1 ,symbols-form) - (,g2 ,values-form)) - (progv ,g1 ,g2 , at body)))) - (t - form)))) - (defun p1-quote (form) (unless (= (length form) 2) (compiler-error "Wrong number of arguments for special operator ~A (expected 1, but received ~D)." @@ -1197,55 +1187,8 @@ (when (unsafe-p arg) (return t)))))))) -(defknown rewrite-return-from (t) t) -(defun rewrite-return-from (form) - (let* ((args (cdr form)) - (result-form (second args)) - (var (gensym))) - (if (unsafe-p (cdr args)) - (if (single-valued-p result-form) - `(let ((,var ,result-form)) - (return-from ,(first args) ,var)) - `(let ((,var (multiple-value-list ,result-form))) - (return-from ,(first args) (values-list ,var)))) - form))) - - -(defknown rewrite-throw (t) t) -(defun rewrite-throw (form) - (let ((args (cdr form))) - (if (unsafe-p args) - (let ((syms ()) - (lets ())) - ;; Tag. - (let ((arg (first args))) - (if (constantp arg) - (push arg syms) - (let ((sym (gensym))) - (push sym syms) - (push (list sym arg) lets)))) - ;; Result. "If the result-form produces multiple values, then all the - ;; values are saved." - (let ((arg (second args))) - (if (constantp arg) - (push arg syms) - (let ((sym (gensym))) - (cond ((single-valued-p arg) - (push sym syms) - (push (list sym arg) lets)) - (t - (push (list 'VALUES-LIST sym) syms) - (push (list sym - (list 'MULTIPLE-VALUE-LIST arg)) - lets)))))) - (list 'LET* (nreverse lets) (list* 'THROW (nreverse syms)))) - form))) - (defknown p1-throw (t) t) (defun p1-throw (form) - (let ((new-form (rewrite-throw form))) - (when (neq new-form form) - (return-from p1-throw (p1 new-form)))) (list* 'THROW (mapcar #'p1 (cdr form)))) (defknown rewrite-function-call (t) t) Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Mon Jan 3 15:30:12 2011 @@ -645,6 +645,88 @@ collecting form))) (apply #'maybe-emit-clear-values forms-for-emit-clear))) + +(declaim (special *saved-operands* *operand-representations*)) +(defmacro with-operand-accumulation ((&body argument-buildup-body) + &body funcall-body) + `(let (*saved-operands* + *operand-representations* + (*register* *register*)) ;; hmm can we do this?? either body + ;; could allocate registers ... + , at argument-buildup-body + (load-saved-operands) + , at funcall-body)) + +(defun load-saved-operands () + "Load any operands which have been saved into registers +back onto the stack in preparation of the execution of the opcode." + (dolist (operand (reverse *saved-operands*)) + (emit 'aload operand))) + +(defun save-existing-operands () + "If any operands have been compiled to the stack, +save them in registers." + (dotimes (i (length *operand-representations*)) + (let ((register (allocate-register))) + (push register *saved-operands*) + (emit 'astore register))) + + (setf *saved-operands* (nreverse *saved-operands*))) + +(defun compile-operand (form representation) + "Compiles `form` into `representation`, storing the resulting value +on the operand stack, if it's safe to do so. Otherwise stores the value +in a register" + (let ((unsafe (or *saved-operands* + (some-nested-block #'block-opstack-unsafe-p + (find-enclosed-blocks form))))) + (when (and unsafe (null *saved-operands*)) + (save-existing-operands)) + + (compile-form form 'stack representation) + (when unsafe + (let ((register (allocate-register))) + (push register *saved-operands*) + (assert (null representation)) + (emit 'astore register))) + + (push representation *operand-representations*))) + +(defun emit-variable-operand (variable) + "Pushes a variable onto the operand stack, if it's safe to do so. Otherwise +stores the value in a register." + (push (variable-representation variable) *operand-representations*) + (cond + ((and *saved-operands* + (variable-register variable)) + ;; we're in 'safe mode' and the variable is in a register, + ;; instead of binding a new register, just load the existing one + (push (variable-register variable) *saved-operands*)) + (t + (emit-push-variable variable) + (when *saved-operands* ;; safe-mode + (let ((register (allocate-register))) + (push register *saved-operands*) + (assert (null (variable-representation variable))) + (emit 'astore register)))))) + +(defun emit-thread-operand () + (push nil *operand-representations*) + (emit-push-current-thread) + (when *saved-operands* + (let ((register (allocate-register))) + (push register *saved-operands*) + (emit 'astore register)))) + + +(defun emit-load-externalized-object-operand (object) + (push nil *operand-representations*) + (emit-load-externalized-object object) + (when *saved-operands* ;; safe-mode + (let ((register (allocate-register))) + (push register *saved-operands*) + (emit 'astore register)))) + (defknown emit-unbox-fixnum () t) (defun emit-unbox-fixnum () (declare (optimize speed)) @@ -3651,12 +3733,13 @@ (return-from p2-return-from)))) ;; Non-local RETURN. (aver (block-non-local-return-p block)) - (emit-push-variable (block-id-variable block)) - (emit-load-externalized-object (block-name block)) (emit-clear-values) - (compile-form result-form 'stack nil) - (emit-invokestatic +lisp+ "nonLocalReturn" (lisp-object-arg-types 3) - +lisp-object+) + (with-operand-accumulation + ((emit-variable-operand (block-id-variable block)) + (emit-load-externalized-object-operand (block-name block)) + (compile-operand result-form nil)) + (emit-invokestatic +lisp+ "nonLocalReturn" (lisp-object-arg-types 3) + +lisp-object+)) ;; Following code will not be reached, but is needed for JVM stack ;; consistency. (emit 'areturn))) @@ -3723,17 +3806,18 @@ (environment-register (setf (progv-environment-register block) (allocate-register))) (label-START (gensym))) - (compile-form symbols-form 'stack nil) - (compile-form values-form 'stack nil) - (unless (and (single-valued-p symbols-form) - (single-valued-p values-form)) - (emit-clear-values)) - (save-dynamic-environment environment-register) - (label label-START) - ;; Compile call to Lisp.progvBindVars(). - (emit-push-current-thread) - (emit-invokestatic +lisp+ "progvBindVars" - (list +lisp-object+ +lisp-object+ +lisp-thread+) nil) + (with-operand-accumulation + ((compile-operand symbols-form nil) + (compile-operand values-form nil)) + (unless (and (single-valued-p symbols-form) + (single-valued-p values-form)) + (emit-clear-values)) + (save-dynamic-environment environment-register) + (label label-START) + ;; Compile call to Lisp.progvBindVars(). + (emit-push-current-thread) + (emit-invokestatic +lisp+ "progvBindVars" + (list +lisp-object+ +lisp-object+ +lisp-thread+) nil)) ;; Implicit PROGN. (let ((*blocks* (cons block *blocks*))) (compile-progn-body (cdddr form) target representation)) @@ -6499,12 +6583,13 @@ (defun p2-throw (form target representation) ;; FIXME What if we're called with a non-NIL representation? (declare (ignore representation)) - (emit-push-current-thread) - (compile-form (second form) 'stack nil) ; Tag. - (emit-clear-values) ; Do this unconditionally! (MISC.503) - (compile-form (third form) 'stack nil) ; Result. - (emit-invokevirtual +lisp-thread+ "throwToTag" - (lisp-object-arg-types 2) nil) + (with-operand-accumulation + ((emit-thread-operand) + (compile-operand (second form) nil) ; Tag. + (emit-clear-values) ; Do this unconditionally! (MISC.503) + (compile-operand (third form) nil)) ; Result. + (emit-invokevirtual +lisp-thread+ "throwToTag" + (lisp-object-arg-types 2) nil)) ;; Following code will not be reached. (when target (emit-push-nil) From ehuelsmann at common-lisp.net Tue Jan 4 09:23:00 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 04 Jan 2011 04:23:00 -0500 Subject: [armedbear-cvs] r13123 - branches/unsafe-p-removal/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Jan 4 04:22:57 2011 New Revision: 13123 Log: Remove UNSAFE-P from pass2 by eliminating SETQ rewriting. Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Jan 4 04:22:57 2011 @@ -6148,14 +6148,6 @@ (t (compile-function-call form target representation)))) -(declaim (ftype (function (t) t) rewrite-setq)) -(defun rewrite-setq (form) - (let ((expr (%caddr form))) - (if (unsafe-p expr) - (let ((sym (gensym))) - (list 'LET (list (list sym expr)) (list 'SETQ (%cadr form) sym))) - form))) - (defknown p2-setq (t t t) t) (defun p2-setq (form target representation) (unless (= (length form) 3) @@ -6164,37 +6156,44 @@ (variable (find-visible-variable name)) (value-form (%caddr form))) (when (or (null variable) - (variable-special-p variable)) - (let ((new-form (rewrite-setq form))) - (when (neq new-form form) - (return-from p2-setq (compile-form (p1 new-form) target representation)))) + (variable-special-p variable)) ;; We're setting a special variable. (cond ((and variable (variable-binding-register variable) (eq (variable-compiland variable) *current-compiland*) (not (enclosed-by-runtime-bindings-creating-block-p (variable-block variable)))) - (aload (variable-binding-register variable)) + ;; ### choose this compilation order to prevent + ;; with-operand-accumulation (compile-forms-and-maybe-emit-clear-values value-form 'stack nil) - (emit 'dup_x1) ;; copy past th + (emit 'dup) + (aload (variable-binding-register variable)) + (emit 'swap) (emit-putfield +lisp-special-binding+ "value" +lisp-object+)) ((and (consp value-form) (eq (first value-form) 'CONS) (= (length value-form) 3) (var-ref-p (third value-form)) - (eq (variable-name (var-ref-variable (third value-form))) name)) - (emit-push-current-thread) - (emit-load-externalized-object name) - (compile-forms-and-maybe-emit-clear-values (second value-form) 'stack nil) - (emit-invokevirtual +lisp-thread+ "pushSpecial" - (list +lisp-symbol+ +lisp-object+) +lisp-object+)) + (eq (variable-name (var-ref-variable (third value-form))) + name)) + (with-operand-accumulation + ((emit-thread-operand) + (emit-load-externalized-object-operand name) + (compile-operand (second value-form) nil) + (maybe-emit-clear-values (second value-form))) + (emit-invokevirtual +lisp-thread+ "pushSpecial" + (list +lisp-symbol+ +lisp-object+) + +lisp-object+))) (t - (emit-push-current-thread) - (emit-load-externalized-object name) - (compile-forms-and-maybe-emit-clear-values value-form 'stack nil) - (emit-invokevirtual +lisp-thread+ "setSpecialVariable" - (list +lisp-symbol+ +lisp-object+) +lisp-object+))) + (with-operand-accumulation + ((emit-thread-operand) + (emit-load-externalized-object-operand name) + (compile-operand value-form nil) + (maybe-emit-clear-values value-form)) + (emit-invokevirtual +lisp-thread+ "setSpecialVariable" + (list +lisp-symbol+ +lisp-object+) + +lisp-object+)))) (fix-boxing representation nil) (emit-move-from-stack target representation) (return-from p2-setq)) From mevenson at common-lisp.net Tue Jan 4 20:01:46 2011 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 04 Jan 2011 15:01:46 -0500 Subject: [armedbear-cvs] r13124 - trunk/abcl Message-ID: Author: mevenson Date: Tue Jan 4 15:01:43 2011 New Revision: 13124 Log: First draft of CHANGES for abcl-0.24.0. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Tue Jan 4 15:01:43 2011 @@ -1,7 +1,73 @@ +Version 0.24.0 +============== +svn://common-lisp.net/project/armedbear/svn/tags/0.24.0/abcl +(unreleased) + +Features +-------- + +* [svn r13087] Upgraded to ASDF-2.011 + +* [svn r13078] JVM::MAKE-CLASS-INTERFACE-FILE provides an interface + for the creation of Java interfaces as serialized by the new + classwriter code. An example of use can be found in + "examples/misc/dynamic-interfaces.lisp". + +* [svn r13102] More type-conversion helpers in JAVA package: + LIST-FROM-JARRAY, VECTOR-FROM-JARRAY, and LIST-FROM-JENUMERATION. + +* [svn r130103-r13107] Implemented JNULL_REF_P to distinguish a + JAVA-OBJECT which contains a Java "null" from the Lisp NIL. + +Fixes +----- + +* [svn 13117][ticket #117] Fix stack inconsistency error. + +* [svn r13018][ticket #114] Fix strange backtrace growth. + +* [svn r13105] Fix Pathname.java failing to find boot.lisp in an + "unpacked JAR" situation found by running ABCL in the Glassfish v3 + servlet container. + +* [svn r13088] Fix algorithim error in writing byte sequences via + RandomAccessCharacterFile. Found and fixed by David Kirkman. + +* [svn r13090] Make --batch exit, use Lisp.exit() in places where + applicable so that the streams are flushed, hence allowing --eval + output to be flushed. + +* [svn r13094] Eliminate flushes after every character in + javax.scripting support. + +* [svn r13096] For arrays, add initialization with the default value + of the element type if neither INITIAL-ELEMENT nor INITIAL-CONTENT + have been specified. Found by: dmalves_ (freenode irc nick). + +Changes +------- + +* [svn r13091-2] Better error reporting for UnhandledCondition thrown + from the Interpreter, storing the originating Java error in the + "cause" field if the cause is a subclass of JAVA_EXCEPTION. + +* [svn r13097-13100] Slight refactoring of PATHNAME code, further + specifying URI escaping rules. + +* [svn r13101] Reduced verbosity of the AbclScriptEngine. + +* [svn r13111] Added a "tools" directory available in SVN repository + to contain tools for developing ABCL in various states. The first + inhabitant is 'code-grapher.lisp' that provides a prototype to + diagram a JVM instruction sequence via graphviz. + +* [svn r13120] Register each compiler node with its parent. + + Version 0.23.1 ============== svn://common-lisp.net/project/armedbear/svn/tags/0.23.1/abcl -(unreleased) +(01 December 2010) Fixes ----- From mevenson at common-lisp.net Wed Jan 5 07:32:28 2011 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 05 Jan 2011 02:32:28 -0500 Subject: [armedbear-cvs] r13125 - in trunk/abcl: doc/asdf src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Jan 5 02:32:25 2011 New Revision: 13125 Log: Upgrade to ASDF-2.012. Modified: trunk/abcl/doc/asdf/asdf.texinfo trunk/abcl/src/org/armedbear/lisp/asdf.lisp Modified: trunk/abcl/doc/asdf/asdf.texinfo ============================================================================== --- trunk/abcl/doc/asdf/asdf.texinfo (original) +++ trunk/abcl/doc/asdf/asdf.texinfo Wed Jan 5 02:32:25 2011 @@ -1790,7 +1790,10 @@ @section Configuration DSL -Here is the grammar of the s-expression (SEXP) DSL for source-registry configuration: +Here is the grammar of the s-expression (SEXP) DSL for source-registry +configuration: + + at c FIXME: This is too wide for happy compilation into pdf. @example ;; A configuration is a single SEXP starting with keyword :source-registry @@ -1805,6 +1808,11 @@ :inherit-configuration | ; splices inherited configuration (often specified last) :ignore-inherited-configuration | ; drop inherited configuration (specified anywhere) + ;; forward compatibility directive (since ASDF 2.011.4), useful when + ;; you want to use new configuration features but have to bootstrap a + ;; the newer required ASDF from an older release that doesn't sport said features: + :ignore-invalid-entries | ; drops subsequent invalid entries instead of erroring out + ;; add a single directory to be scanned (no recursion) (:directory DIRECTORY-PATHNAME-DESIGNATOR) | @@ -1837,12 +1845,14 @@ PATHNAME | ;; pathname (better be an absolute path, or bust) :HOME | ;; designates the user-homedir-pathname ~/ :USER-CACHE | ;; designates the default location for the user cache - :SYSTEM-CACHE ;; designates the default location for the system cache + :SYSTEM-CACHE | ;; designates the default location for the system cache + :HERE ;; designates the location of the configuration file + ;; (or *default-pathname-defaults*, if invoked interactively) RELATIVE-COMPONENT-DESIGNATOR := STRING | ;; namestring (directory assumed where applicable) PATHNAME | ;; pathname - :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.32.30-linux-x86-64 + :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.45-linux-amd64 :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl :UID | ;; current UID -- not available on Windows :USER ;; current USER name -- NOT IMPLEMENTED(!) @@ -1863,7 +1873,7 @@ @section Configuration Directories -Configuration directories consist in files each contains +Configuration directories consist in files each containing a list of directives without any enclosing @code{(:source-registry ...)} form. The files will be sorted by namestring as if by @code{string<} and the lists of directives of these files with be concatenated in order. @@ -1897,6 +1907,50 @@ (:tree "/home/fare/cl/") @end example + at subsection The :here directive + +The @code{:here} directive is an absolute pathname designator that +refers to the directory containing the configuration file currently +being processed. + +The @code{:here} directive is intended to simplify the delivery of +complex CL systems, and for easy configuration of projects shared through +revision control systems, in accordance with our design principle that +each participant should be able to provide all and only the information +available to him or her. + +Consider a person X who has set up the source code repository for a +complex project with a master directory @file{dir/}. Ordinarily, one +might simply have the user add a directive that would look something +like this: + at example + (:tree "path/to/dir") + at end example +But what if X knows that there are very large subtrees +under dir that are filled with, e.g., Java source code, image files for +icons, etc.? All of the asdf system definitions are contained in the +subdirectories @file{dir/src/lisp/} and @file{dir/extlib/lisp/}, and +these are the only directories that should be searched. + +In this case, X can put into @file{dir/} a file @file{asdf.conf} that +contains the following: + at example +(:source-registry + (:tree (:here "src/lisp/")) + (:tree (:here "extlib/lisp")) + (:directory (:here "outlier/"))) + at end example + +Then when someone else (call her Y) checks out a copy of this +repository, she need only add + at example +(:include "/path/to/my/checkout/directory/asdf.conf") + at end example +to one of her previously-existing asdf source location configuration +files, or invoke @code{initialize-source-registry} with a configuration +form containing that s-expression. ASDF will find the .conf file that X +has provided, and then set up source locations within the working +directory according to X's (relative) instructions. @section Shell-friendly syntax for configuration @@ -2190,10 +2244,8 @@ @section Backward Compatibility + at cindex ASDF-BINARY-LOCATIONS compatibility - at c FIXME -- I think we should provide an easy way - at c to get behavior equivalent to A-B-L and - at c I will propose a technique for doing this. We purposefully do NOT provide backward compatibility with earlier versions of @code{ASDF-Binary-Locations} (8 Sept 2009), @@ -2221,7 +2273,7 @@ Nevertheless, if you are a fan of @code{ASDF-Binary-Locations}, we provide a limited emulation mode: - at defun asdf:enable-asdf-binary-locations-compatibility @&key centralize-lisp-binaries default-toplevel-directory include-per-user-information map-all-source-files source-to-target-mappings + at defun enable-asdf-binary-locations-compatibility @&key centralize-lisp-binaries default-toplevel-directory include-per-user-information map-all-source-files source-to-target-mappings This function will initialize the new @code{asdf-output-translations} facility in a way that emulates the behavior of the old @code{ASDF-Binary-Locations} facility. Where you would previously set global variables @@ -2264,10 +2316,15 @@ :inherit-configuration | ; splices inherited configuration (often specified last) :ignore-inherited-configuration | ; drop inherited configuration (specified anywhere) + ;; forward compatibility directive (since ASDF 2.011.4), useful when + ;; you want to use new configuration features but have to bootstrap a + ;; the newer required ASDF from an older release that doesn't sport said features: + :ignore-invalid-entries | ; drops subsequent invalid entries instead of erroring out + ;; include a configuration file or directory (:include PATHNAME-DESIGNATOR) | - ;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.35-x86-64/ or something. + ;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.45-linux-amd64/ or something. :enable-user-cache | ;; Disable global cache. Map / to / :disable-cache | @@ -2295,8 +2352,11 @@ RELATIVE-COMPONENT-DESIGNATOR := STRING | ;; namestring, directory is assumed. If the last component, /**/*.* is added PATHNAME | ;; pathname unless last component, directory is assumed. - :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.32.30-linux-x86-64 + :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.45-linux-amd64 :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl + :*/ | ;; any direct subdirectory (since ASDF 2.011.4) + :**/ | ;; any recursively inferior subdirectory (since ASDF 2.011.4) + :*.*.* | ;; any file (since ASDF 2.011.4) :UID | ;; current UID -- not available on Windows :USER ;; current USER name -- NOT IMPLEMENTED(!) @@ -2332,8 +2392,26 @@ before it is translated. When the second designator is @code{t}, the mapping is the identity. -When the second designator starts with @code{root}, +When the second designator starts with @code{:root}, the mapping preserves the host and device of the original pathname. +Notably, this allows you to map files +to a subdirectory of the whichever directory the file is in. +Though the syntax is not quite as easy to use as we'd like, +you can have an (source destination) mapping entry such as follows +in your configuration file, +or you may use @code{enable-asdf-binary-locations-compatibility} +with @code{:centralize-lisp-binaries nil} +which will do the same thing internally for you: + at verbatim + #.(let ((wild-subdir (make-pathname :directory '(:relative :wild-inferiors))) + (wild-file (make-pathname :name :wild :version :wild :type :wild))) + `((:root ,wild-subdir ,wild-file) ;; Or using the implicit wildcard, just :root + (:root ,wild-subdir :implementation ,wild-file))) + at end verbatim +Starting with ASDF 2.011.4, you can use the simpler: + @code{`(:root (:root :**/ :implementation :*.*.*))} + + @code{:include} statements cause the search to recurse with the path specifications from the file specified. @@ -2532,7 +2610,7 @@ @c @itemize @c @item - at c SBCL, version 1.0 on Mac OS X for intel: @code{sbcl-1.0-darwin-x86} + at c SBCL, version 1.0.45 on Mac OS X for Intel: @code{sbcl-1.0.45-darwin-x86} @c @item @c Franz Allegro, version 8.0, ANSI Common Lisp: @code{allegro-8.0a-macosx-x86} @@ -2649,11 +2727,13 @@ @chapter Getting the latest version Decide which version you want. -HEAD is the newest version and usually OK, whereas -RELEASE is for cautious people -(e.g. who already have systems using ASDF that they don't want broken), -a slightly older version about which none of the HEAD users have complained. -There is also a STABLE version, which is earlier than release. +The @code{master} branch is where development happens; +its @code{HEAD} is usually OK, including the latest fixes and portability tweaks, +but an occasional regression may happen despite our (limited) test suite. + +The @code{release} branch is what cautious people should be using; +it has usually been tested more, and releases are cut at a point +where there isn't any known unresolved issue. You may get the ASDF source repository using git: @kbd{git clone git://common-lisp.net/projects/asdf/asdf.git} @@ -2921,7 +3001,7 @@ The new ASDF output translations are incompatible with ASDF-Binary-Locations. They replace A-B-L, and there is compatibility mode to emulate your previous A-B-L configuration. -See @code{asdf:enable-asdf-binary-locations-compatibility} in +See @code{enable-asdf-binary-locations-compatibility} in @pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}. But thou shall not load ABL on top of ASDF 2. @@ -2999,7 +3079,7 @@ Starting with current candidate releases of ASDF 2, it should always be a good time to upgrade to a recent ASDF. You may consult with the maintainer for which specific version they recommend, -but the latest RELEASE should be correct. +but the latest @code{release} should be correct. We trust you to thoroughly test it with your implementation before you release it. If there are any issues with the current release, it's a bug that you should report upstream and that we will fix ASAP. 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 Wed Jan 5 02:32:25 2011 @@ -74,11 +74,13 @@ (defvar *asdf-version* nil) (defvar *upgraded-p* nil) (let* (;; For bug reporting sanity, please always bump this version when you modify this file. + ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version + ;; can help you do these changes in synch (look at the source for documentation). ;; "2.345" would be an official release ;; "2.345.6" would be a development version in the official upstream - ;; "2.345.0.7" would be your local modification of an official release - ;; "2.345.6.7" would be your local modification of a development version - (asdf-version "2.011") + ;; "2.345.0.7" would be your seventh local modification of official release 2.345 + ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 + (asdf-version "2.012") (existing-asdf (fboundp 'find-system)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -496,7 +498,7 @@ ;; Giving :unspecific as argument to make-pathname is not portable. ;; See CLHS make-pathname and 19.2.2.2.3. ;; We only use it on implementations that support it. - (or #+(or ccl ecl gcl lispworks sbcl) :unspecific))) + (or #+(or ccl gcl lispworks sbcl) :unspecific))) (destructuring-bind (name &optional (type unspecific)) (split-string filename :max 2 :separator ".") (if (equal name "") @@ -713,9 +715,14 @@ (defun* lispize-pathname (input-file) (make-pathname :type "lisp" :defaults input-file)) +(defparameter *wild-file* + (make-pathname :name :wild :type :wild :version :wild :directory nil)) +(defparameter *wild-directory* + (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)) +(defparameter *wild-inferiors* + (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil)) (defparameter *wild-path* - (make-pathname :directory '(:relative :wild-inferiors) - :name :wild :type :wild :version :wild)) + (merge-pathnames *wild-file* *wild-inferiors*)) (defun* wilden (path) (merge-pathnames* *wild-path* path)) @@ -865,8 +872,12 @@ (asdf-message "~&~@<; ~@; Updating ~A for ASDF ~A~@:>~%" m ,(asdf-version))) (when (member 'components-by-name added) (compute-module-components-by-name m)) - (when (and (typep m 'system) (member 'source-file added)) - (%set-system-source-file (probe-asd (component-name m) (component-pathname m)) m)))))) + (when (typep m 'system) + (when (member 'source-file added) + (%set-system-source-file + (probe-asd (component-name m) (component-pathname m)) m) + (when (equal (component-name m) "asdf") + (setf (component-version m) *asdf-version*)))))))) ;;;; ------------------------------------------------------------------------- ;;;; Classes, Conditions @@ -939,6 +950,21 @@ (define-condition compile-failed (compile-error) ()) (define-condition compile-warned (compile-error) ()) +(define-condition invalid-configuration () + ((form :reader condition-form :initarg :form) + (location :reader condition-location :initarg :location) + (format :reader condition-format :initarg :format) + (arguments :reader condition-arguments :initarg :arguments :initform nil)) + (:report (lambda (c s) + (format s "~@<~? (will be skipped)~@:>" + (condition-format c) + (list* (condition-form c) (condition-location c) + (condition-arguments c)))))) +(define-condition invalid-source-registry (invalid-configuration warning) + ((format :initform "~@"))) +(define-condition invalid-output-translation (invalid-configuration warning) + ((format :initform "~@"))) + (defclass component () ((name :accessor component-name :initarg :name :documentation "Component name: designator for a string composed of portable pathname characters") @@ -1151,11 +1177,8 @@ Note that this does NOT in any way cause the code of the system to be unloaded." ;; There is no "unload" operation in Common Lisp, and a general such operation ;; cannot be portably written, considering how much CL relies on side-effects - ;; of global data structures. - ;; Note that this does a setf gethash instead of a remhash - ;; this way there remains a hint in the *defined-systems* table - ;; that the system was loaded at some point. - (setf (gethash (coerce-name name) *defined-systems*) nil)) + ;; to global data structures. + (remhash (coerce-name name) *defined-systems*)) (defun* map-systems (fn) "Apply FN to each defined system. @@ -1289,27 +1312,34 @@ (defmethod find-system (name &optional (error-p t)) (find-system (coerce-name name) error-p)) +(defun load-sysdef (name pathname) + ;; Tries to load system definition with canonical NAME from PATHNAME. + (let ((package (make-temporary-package))) + (unwind-protect + (handler-bind + ((error (lambda (condition) + (error 'load-system-definition-error + :name name :pathname pathname + :condition condition)))) + (let ((*package* package)) + (asdf-message + "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%" + pathname package) + (load pathname))) + (delete-package package)))) + (defmethod find-system ((name string) &optional (error-p t)) (catch 'find-system - (let* ((in-memory (system-registered-p name)) + (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk (on-disk (system-definition-pathname name))) (when (and on-disk (or (not in-memory) - (< (car in-memory) (safe-file-write-date on-disk)))) - (let ((package (make-temporary-package))) - (unwind-protect - (handler-bind - ((error (lambda (condition) - (error 'load-system-definition-error - :name name :pathname on-disk - :condition condition)))) - (let ((*package* package)) - (asdf-message - "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%" - on-disk *package*) - (load on-disk))) - (delete-package package)))) - (let ((in-memory (system-registered-p name))) + ;; don't reload if it's already been loaded, + ;; or its filestamp is in the future which means some clock is skewed + ;; and trying to load might cause an infinite loop. + (< (car in-memory) (safe-file-write-date on-disk) (get-universal-time)))) + (load-sysdef name on-disk)) + (let ((in-memory (system-registered-p name))) ; try again after loading from disk (cond (in-memory (when on-disk @@ -1340,7 +1370,8 @@ (throw 'find-system system)))) (defun* sysdef-find-asdf (name) - (find-system-fallback name "asdf")) ;; :version *asdf-version* wouldn't be updated when ASDF is updated. + ;; Bug: :version *asdf-version* won't be updated when ASDF is updated. + (find-system-fallback name "asdf" :version *asdf-version*)) ;;;; ------------------------------------------------------------------------- @@ -1650,8 +1681,7 @@ required-op required-c required-v)) (retry () :report (lambda (s) - (format s "~@" - (component-find-path required-c))) + (format s "~@" required-c)) :test (lambda (c) (or (null c) @@ -2408,7 +2438,7 @@ exit-code) #+clisp ;XXX not exactly *verbose-out*, I know - (ext:run-shell-command command :output :terminal :wait t) + (or (ext:run-shell-command command :output :terminal :wait t) 0) #+clozure (nth-value 1 @@ -2586,7 +2616,8 @@ *implementation-features*)) (os (maybe-warn (first-feature *os-features*) "No os feature found in ~a." *os-features*)) - (arch (maybe-warn (first-feature *architecture-features*) + (arch #+clisp "" #-clisp + (maybe-warn (first-feature *architecture-features*) "No architecture feature found in ~a." *architecture-features*)) (version (maybe-warn (lisp-version-string) @@ -2596,7 +2627,6 @@ (format nil "~(~@{~a~^-~}~)" lisp version os arch))))) - ;;; --------------------------------------------------------------------------- ;;; Generic support for configuration files @@ -2649,40 +2679,88 @@ (or (member x kw) (and (length=n-p x 1) (member (car x) kw))))) +(defun* report-invalid-form (reporter &rest args) + (etypecase reporter + (null + (apply 'error 'invalid-configuration args)) + (function + (apply reporter args)) + ((or symbol string) + (apply 'error reporter args)) + (cons + (apply 'apply (append reporter args))))) + +(defvar *ignored-configuration-form* nil) + (defun* validate-configuration-form (form tag directive-validator - &optional (description tag)) + &key location invalid-form-reporter) (unless (and (consp form) (eq (car form) tag)) - (error "Error: Form doesn't specify ~A ~S~%" description form)) - (loop :with inherit = 0 - :for directive :in (cdr form) :do - (if (configuration-inheritance-directive-p directive) - (incf inherit) - (funcall directive-validator directive)) + (setf *ignored-configuration-form* t) + (report-invalid-form invalid-form-reporter :form form :location location) + (return-from validate-configuration-form nil)) + (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag) + :for directive :in (cdr form) + :when (cond + ((configuration-inheritance-directive-p directive) + (incf inherit) t) + ((eq directive :ignore-invalid-entries) + (setf ignore-invalid-p t) t) + ((funcall directive-validator directive) + t) + (ignore-invalid-p + nil) + (t + (setf *ignored-configuration-form* t) + (report-invalid-form invalid-form-reporter :form directive :location location) + nil)) + :do (push directive x) :finally (unless (= inherit 1) - (error "One and only one of ~S or ~S is required" - :inherit-configuration :ignore-inherited-configuration))) - form) + (report-invalid-form invalid-form-reporter + :arguments (list "One and only one of ~S or ~S is required" + :inherit-configuration :ignore-inherited-configuration))) + (return (nreverse x)))) -(defun* validate-configuration-file (file validator description) +(defun* validate-configuration-file (file validator &key description) (let ((forms (read-file-forms file))) (unless (length=n-p forms 1) (error "One and only one form allowed for ~A. Got: ~S~%" description forms)) - (funcall validator (car forms)))) + (funcall validator (car forms) :location file))) (defun* hidden-file-p (pathname) (equal (first-char (pathname-name pathname)) #\.)) -(defun* validate-configuration-directory (directory tag validator) +(defun* directory* (pathname-spec &rest keys &key &allow-other-keys) + (apply 'directory pathname-spec + (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) + #+ccl '(:follow-links nil) + #+clisp '(:circle t :if-does-not-exist :ignore) + #+(or cmu scl) '(:follow-links nil :truenamep nil) + #+sbcl (when (find-symbol "RESOLVE-SYMLINKS" "SB-IMPL") '(:resolve-symlinks nil)))))) + +(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter) + "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will +be applied to the results to yield a configuration form. Current +values of TAG include :source-registry and :output-translations." (let ((files (sort (ignore-errors (remove-if 'hidden-file-p - (directory (make-pathname :name :wild :type "conf" :defaults directory) - #+sbcl :resolve-symlinks #+sbcl nil))) + (directory* (make-pathname :name :wild :type "conf" :defaults directory)))) #'string< :key #'namestring))) `(,tag ,@(loop :for file :in files :append - (mapcar validator (read-file-forms file))) + (loop :with ignore-invalid-p = nil + :for form :in (read-file-forms file) + :when (eq form :ignore-invalid-entries) + :do (setf ignore-invalid-p t) + :else + :when (funcall validator form) + :collect form + :else + :when ignore-invalid-p + :do (setf *ignored-configuration-form* t) + :else + :do (report-invalid-form invalid-form-reporter :form form :location file))) :inherit-configuration))) @@ -2722,7 +2800,8 @@ (etypecase (car x) ((eql t) -1) (pathname - (length (pathname-directory (car x))))))))) + (let ((directory (pathname-directory (car x)))) + (if (listp directory) (length directory) 0)))))))) new-value) (defun* output-translations-initialized-p () @@ -2756,6 +2835,9 @@ (merge-pathnames* cdr car))))) ((eql :default-directory) (relativize-pathname-directory (default-directory))) + ((eql :*/) *wild-directory*) + ((eql :**/) *wild-inferiors*) + ((eql :*.*.*) *wild-file*) ((eql :implementation) (implementation-identifier)) ((eql :implementation-type) (string-downcase (implementation-type))) #-(and (or win32 windows mswindows mingw32) (not cygwin)) @@ -2766,6 +2848,11 @@ (error "pathname ~S is not relative to ~S" s super)) (merge-pathnames* s super))) +(defvar *here-directory* nil + "This special variable is bound to the currect directory during calls to +PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here +directive.") + (defun* resolve-absolute-location-component (x &key directory wilden) (let* ((r (etypecase x @@ -2788,6 +2875,11 @@ (let ((p (make-pathname :directory '(:relative)))) (if wilden (wilden p) p)))) ((eql :home) (user-homedir)) + ((eql :here) + (resolve-location (or *here-directory* + ;; give semantics in the case of use interactively + :default-directory) + :directory t :wilden nil)) ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil)) ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil)) ((eql :default-directory) (default-directory)))) @@ -2812,8 +2904,17 @@ :finally (return path)))) (defun* location-designator-p (x) - (flet ((componentp (c) (typep c '(or string pathname keyword)))) - (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x))))) + (flet ((absolute-component-p (c) + (typep c '(or string pathname + (member :root :home :here :user-cache :system-cache :default-directory)))) + (relative-component-p (c) + (typep c '(or string pathname + (member :default-directory :*/ :**/ :*.*.* + :implementation :implementation-type + #-(and (or win32 windows mswindows mingw32) (not cygwin)) :uid))))) + (or (typep x 'boolean) + (absolute-component-p x) + (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x)))))) (defun* location-function-p (x) (and @@ -2826,47 +2927,43 @@ (length=n-p (second x) 2))))) (defun* validate-output-translations-directive (directive) - (unless - (or (member directive '(:inherit-configuration - :ignore-inherited-configuration - :enable-user-cache :disable-cache nil)) - (and (consp directive) - (or (and (length=n-p directive 2) - (or (and (eq (first directive) :include) - (typep (second directive) '(or string pathname null))) - (and (location-designator-p (first directive)) - (or (location-designator-p (second directive)) - (location-function-p (second directive)))))) - (and (length=n-p directive 1) - (location-designator-p (first directive)))))) - (error "Invalid directive ~S~%" directive)) - directive) + (or (member directive '(:enable-user-cache :disable-cache nil)) + (and (consp directive) + (or (and (length=n-p directive 2) + (or (and (eq (first directive) :include) + (typep (second directive) '(or string pathname null))) + (and (location-designator-p (first directive)) + (or (location-designator-p (second directive)) + (location-function-p (second directive)))))) + (and (length=n-p directive 1) + (location-designator-p (first directive))))))) -(defun* validate-output-translations-form (form) +(defun* validate-output-translations-form (form &key location) (validate-configuration-form form :output-translations 'validate-output-translations-directive - "output translations")) + :location location :invalid-form-reporter 'invalid-output-translation)) (defun* validate-output-translations-file (file) (validate-configuration-file - file 'validate-output-translations-form "output translations")) + file 'validate-output-translations-form :description "output translations")) (defun* validate-output-translations-directory (directory) (validate-configuration-directory - directory :output-translations 'validate-output-translations-directive)) + directory :output-translations 'validate-output-translations-directive + :invalid-form-reporter 'invalid-output-translation)) -(defun* parse-output-translations-string (string) +(defun* parse-output-translations-string (string &key location) (cond ((or (null string) (equal string "")) '(:output-translations :inherit-configuration)) ((not (stringp string)) (error "environment string isn't: ~S" string)) ((eql (char string 0) #\") - (parse-output-translations-string (read-from-string string))) + (parse-output-translations-string (read-from-string string) :location location)) ((eql (char string 0) #\() - (validate-output-translations-form (read-from-string string))) + (validate-output-translations-form (read-from-string string) :location location)) (t (loop :with inherit = nil @@ -2974,7 +3071,7 @@ (process-output-translations-directive '(t t) :collect collect)) ((:inherit-configuration) (inherit-output-translations inherit :collect collect)) - ((:ignore-inherited-configuration nil) + ((:ignore-inherited-configuration :ignore-invalid-entries nil) nil)) (let ((src (first directive)) (dst (second directive))) @@ -2997,9 +3094,7 @@ (t (let* ((trudst (make-pathname :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc))) - (wilddst (make-pathname - :name :wild :type :wild :version :wild - :defaults trudst))) + (wilddst (merge-pathnames* *wild-file* trudst))) (funcall collect (list wilddst t)) (funcall collect (list trusrc trudst))))))))))) @@ -3160,21 +3255,19 @@ (when (null map-all-source-files) (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP")) (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp"))) - (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors))) - (mapped-files (make-pathname - :name :wild :version :wild - :type (if map-all-source-files :wild fasl-type))) + (mapped-files (if map-all-source-files *wild-file* + (make-pathname :name :wild :version :wild :type fasl-type))) (destination-directory (if centralize-lisp-binaries `(,default-toplevel-directory ,@(when include-per-user-information (cdr (pathname-directory (user-homedir)))) - :implementation ,wild-inferiors) - `(:root ,wild-inferiors :implementation)))) + :implementation ,*wild-inferiors*) + `(:root ,*wild-inferiors* :implementation)))) (initialize-output-translations `(:output-translations , at source-to-target-mappings - ((:root ,wild-inferiors ,mapped-files) + ((:root ,*wild-inferiors* ,mapped-files) (, at destination-directory ,mapped-files)) (t t) :ignore-inherited-configuration)))) @@ -3294,31 +3387,23 @@ (make-pathname :directory nil :name :wild :type "asd" :version :newest)) (defun directory-has-asd-files-p (directory) - (and (ignore-errors - (directory (merge-pathnames* *wild-asd* directory) - #+sbcl #+sbcl :resolve-symlinks nil - #+ccl #+ccl :follow-links nil - #+clisp #+clisp :circle t)) - t)) + (ignore-errors + (directory* (merge-pathnames* *wild-asd* directory)) + t)) (defun subdirectories (directory) (let* ((directory (ensure-directory-pathname directory)) #-cormanlisp (wild (merge-pathnames* #-(or abcl allegro lispworks scl) - (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil) + *wild-directory* #+(or abcl allegro lispworks scl) "*.*" directory)) (dirs #-cormanlisp (ignore-errors - (directory wild . - #.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) - #+ccl '(:follow-links nil :directories t :files nil) - #+clisp '(:circle t :if-does-not-exist :ignore) - #+(or cmu scl) '(:follow-links nil :truenamep nil) - #+digitool '(:directories t) - #+sbcl '(:resolve-symlinks nil)))) + (directory* wild . #.(or #+ccl '(:directories t :files nil) + #+digitool '(:directories t)))) #+cormanlisp (cl::directory-subdirs directory)) #+(or abcl allegro lispworks scl) (dirs (remove-if-not #+abcl #'extensions:probe-directory @@ -3346,39 +3431,40 @@ collect)) (defun* validate-source-registry-directive (directive) - (unless - (or (member directive '(:default-registry (:default-registry)) :test 'equal) - (destructuring-bind (kw &rest rest) directive - (case kw - ((:include :directory :tree) - (and (length=n-p rest 1) - (location-designator-p (first rest)))) - ((:exclude :also-exclude) - (every #'stringp rest)) - (null rest)))) - (error "Invalid directive ~S~%" directive)) - directive) + (or (member directive '(:default-registry)) + (and (consp directive) + (let ((rest (rest directive))) + (case (first directive) + ((:include :directory :tree) + (and (length=n-p rest 1) + (location-designator-p (first rest)))) + ((:exclude :also-exclude) + (every #'stringp rest)) + ((:default-registry) + (null rest))))))) -(defun* validate-source-registry-form (form) +(defun* validate-source-registry-form (form &key location) (validate-configuration-form - form :source-registry 'validate-source-registry-directive "a source registry")) + form :source-registry 'validate-source-registry-directive + :location location :invalid-form-reporter 'invalid-source-registry)) (defun* validate-source-registry-file (file) (validate-configuration-file - file 'validate-source-registry-form "a source registry")) + file 'validate-source-registry-form :description "a source registry")) (defun* validate-source-registry-directory (directory) (validate-configuration-directory - directory :source-registry 'validate-source-registry-directive)) + directory :source-registry 'validate-source-registry-directive + :invalid-form-reporter 'invalid-source-registry)) -(defun* parse-source-registry-string (string) +(defun* parse-source-registry-string (string &key location) (cond ((or (null string) (equal string "")) '(:source-registry :inherit-configuration)) ((not (stringp string)) (error "environment string isn't: ~S" string)) ((find (char string 0) "\"(") - (validate-source-registry-form (read-from-string string))) + (validate-source-registry-form (read-from-string string) :location location)) (t (loop :with inherit = nil @@ -3475,11 +3561,13 @@ (defmethod process-source-registry ((pathname pathname) &key inherit register) (cond ((directory-pathname-p pathname) - (process-source-registry (validate-source-registry-directory pathname) - :inherit inherit :register register)) + (let ((*here-directory* (truenamize pathname))) + (process-source-registry (validate-source-registry-directory pathname) + :inherit inherit :register register))) ((probe-file pathname) - (process-source-registry (validate-source-registry-file pathname) - :inherit inherit :register register)) + (let ((*here-directory* (pathname-directory-pathname pathname))) + (process-source-registry (validate-source-registry-file pathname) + :inherit inherit :register register))) (t (inherit-source-registry inherit :register register)))) (defmethod process-source-registry ((string string) &key inherit register) @@ -3527,13 +3615,14 @@ (defun* flatten-source-registry (&optional parameter) (remove-duplicates (while-collecting (collect) - (inherit-source-registry - `(wrapping-source-registry - ,parameter - ,@*default-source-registries*) - :register (lambda (directory &key recurse exclude) - (collect (list directory :recurse recurse :exclude exclude))))) - :test 'equal :from-end t)) + (let ((*default-pathname-defaults* (default-directory))) + (inherit-source-registry + `(wrapping-source-registry + ,parameter + ,@*default-source-registries*) + :register (lambda (directory &key recurse exclude) + (collect (list directory :recurse recurse :exclude exclude))))) + :test 'equal :from-end t))) ;; Will read the configuration and initialize all internal variables, ;; and return the new configuration. @@ -3617,6 +3706,11 @@ (declare (ignorable initargs)) (when system-p (appendf (compile-op-flags op) (list :system-p system-p)))))) +;;; If a previous version of ASDF failed to read some configuration, try again. +(when *ignored-configuration-form* + (clear-configuration) + (setf *ignored-configuration-form* nil)) + ;;;; ----------------------------------------------------------------- ;;;; Done! (when *load-verbose* From mevenson at common-lisp.net Wed Jan 5 07:36:00 2011 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 05 Jan 2011 02:36:00 -0500 Subject: [armedbear-cvs] r13126 - trunk/abcl Message-ID: Author: mevenson Date: Wed Jan 5 02:36:00 2011 New Revision: 13126 Log: Reorder CHANGES for abcl-0.24.0 in (mostly) reverse chronological order. Note upgrade to ASDF-2.012 Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Wed Jan 5 02:36:00 2011 @@ -6,23 +6,24 @@ Features -------- -* [svn r13087] Upgraded to ASDF-2.011 +* [svn r130103-r13107] Implemented JNULL_REF_P to distinguish a + JAVA-OBJECT which contains a Java "null" from the Lisp NIL. + +* [svn r13102] More type-conversion helpers in JAVA package: + LIST-FROM-JARRAY, VECTOR-FROM-JARRAY, and LIST-FROM-JENUMERATION. * [svn r13078] JVM::MAKE-CLASS-INTERFACE-FILE provides an interface for the creation of Java interfaces as serialized by the new classwriter code. An example of use can be found in "examples/misc/dynamic-interfaces.lisp". -* [svn r13102] More type-conversion helpers in JAVA package: - LIST-FROM-JARRAY, VECTOR-FROM-JARRAY, and LIST-FROM-JENUMERATION. +* [svn r13087] Upgraded to ASDF-2.012 -* [svn r130103-r13107] Implemented JNULL_REF_P to distinguish a - JAVA-OBJECT which contains a Java "null" from the Lisp NIL. Fixes ----- -* [svn 13117][ticket #117] Fix stack inconsistency error. +* [svn r13117][ticket #117] Fix stack inconsistency error. * [svn r13018][ticket #114] Fix strange backtrace growth. @@ -30,38 +31,39 @@ "unpacked JAR" situation found by running ABCL in the Glassfish v3 servlet container. -* [svn r13088] Fix algorithim error in writing byte sequences via - RandomAccessCharacterFile. Found and fixed by David Kirkman. +* [svn r13096] For arrays, add initialization with the default value + of the element type if neither INITIAL-ELEMENT nor INITIAL-CONTENT + have been specified. Found by: dmalves_ (freenode irc nick). + +* [svn r13094] Eliminate flushes after every character in + javax.scripting support. * [svn r13090] Make --batch exit, use Lisp.exit() in places where applicable so that the streams are flushed, hence allowing --eval output to be flushed. -* [svn r13094] Eliminate flushes after every character in - javax.scripting support. +* [svn r13088] Fix algorithim error in writing byte sequences via + RandomAccessCharacterFile. Found and fixed by David Kirkman. -* [svn r13096] For arrays, add initialization with the default value - of the element type if neither INITIAL-ELEMENT nor INITIAL-CONTENT - have been specified. Found by: dmalves_ (freenode irc nick). Changes ------- -* [svn r13091-2] Better error reporting for UnhandledCondition thrown - from the Interpreter, storing the originating Java error in the - "cause" field if the cause is a subclass of JAVA_EXCEPTION. - -* [svn r13097-13100] Slight refactoring of PATHNAME code, further - specifying URI escaping rules. - -* [svn r13101] Reduced verbosity of the AbclScriptEngine. +* [svn r13120] Register each compiler node with its parent. * [svn r13111] Added a "tools" directory available in SVN repository to contain tools for developing ABCL in various states. The first inhabitant is 'code-grapher.lisp' that provides a prototype to diagram a JVM instruction sequence via graphviz. -* [svn r13120] Register each compiler node with its parent. +* [svn r13101] Reduced verbosity of the AbclScriptEngine. + +* [svn r13097-13100] Slight refactoring of PATHNAME code, further + specifying URI escaping rules. + +* [svn r13091-2] Better error reporting for UnhandledCondition thrown + from the Interpreter, storing the originating Java error in the + "cause" field if the cause is a subclass of JAVA_EXCEPTION. Version 0.23.1 From ehuelsmann at common-lisp.net Thu Jan 6 13:42:56 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 06 Jan 2011 08:42:56 -0500 Subject: [armedbear-cvs] r13127 - branches/unsafe-p-removal/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jan 6 08:42:55 2011 New Revision: 13127 Log: Remove UNSAFE-P from pass1, except for rewriting function calls, which takes a lot more effort to complete. Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Thu Jan 6 08:42:55 2011 @@ -398,24 +398,7 @@ (setf (cdr form) (p1-body (cdr form))) form) -(defknown p1-if (t) t) -(defun p1-if (form) - (let ((test (cadr form))) - (cond ((unsafe-p test) - (cond ((and (consp test) - (memq (%car test) '(GO RETURN-FROM THROW))) - (p1 test)) - (t - (let* ((var (gensym)) - (new-form - `(let ((,var ,test)) - (if ,var ,(third form) ,(fourth form))))) - (p1 new-form))))) - (t - (p1-default form))))) - - -(defmacro p1-let/let*-vars +(defmacro p1-let/let*-vars (block varlist variables-var var body1 body2) (let ((varspec (gensym)) (initform (gensym)) @@ -1358,7 +1341,11 @@ (FUNCALL p1-funcall) (FUNCTION p1-function) (GO p1-go) - (IF p1-if) + (IF p1-default) + ;; used to be p1-if, which was used to rewrite the test + ;; form to a LET-binding; that's not necessary, because + ;; the test form doesn't lead to multiple operands on the + ;; operand stack (LABELS p1-labels) (LAMBDA p1-lambda) (LET p1-let/let*) From vvoutilainen at common-lisp.net Thu Jan 6 13:55:23 2011 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Thu, 06 Jan 2011 08:55:23 -0500 Subject: [armedbear-cvs] r13128 - public_html/doc Message-ID: Author: vvoutilainen Date: Thu Jan 6 08:55:21 2011 New Revision: 13128 Log: Fix example links. Modified: public_html/doc/abcl-user.html Modified: public_html/doc/abcl-user.html ============================================================================== --- public_html/doc/abcl-user.html (original) +++ public_html/doc/abcl-user.html Thu Jan 6 08:55:21 2011 @@ -163,7 +163,7 @@ } } - See the entire code sample here. + See the entire code sample here.

Lisp code

We need to get the @@ -193,11 +193,11 @@ (result (jcall method param 2 4))) (format t "in void-function, result of calling addTwoNumbers(2, 4): ~a~%" result))) - See the entire code sample here. + See the entire code sample here.

Sample Code

  • - Code examples can be found here. + Code examples can be found here.
  • Conway's Game of Life: This example shows how to call Lisp code from Java.
      @@ -218,4 +218,4 @@ Creative Commons License
      Armed Bear Common Lisp Tutorial by Paul Reiners is licensed under a Creative Commons Attribution-Noncommercial-Share Alike 3.0 United States License. Code samples are released under the GNU General Public License. - \ No newline at end of file + From ehuelsmann at common-lisp.net Thu Jan 6 17:26:34 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 06 Jan 2011 12:26:34 -0500 Subject: [armedbear-cvs] r13129 - branches/unsafe-p-removal/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jan 6 12:26:32 2011 New Revision: 13129 Log: Remove UNSAFE-P from SINGLE-VALUED-P (pass2). Note: The use of UNSAFE-P was misguided. TAGBODY returns NIL, not any of the values in the body. UNSAFE-P was used to determine (non-local) returns. BLOCKs do not only return the value of the last form, but can also return any of the values from the VALUES-FORM in RETURN-FROM. Etc, etc. Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Thu Jan 6 12:26:32 2011 @@ -643,8 +643,10 @@ (t (setf (block-non-local-return-p block) t))) (when (block-non-local-return-p block) - (dformat t "non-local return from block ~S~%" (block-name block)))) - (list* 'RETURN-FROM (cadr form) (mapcar #'p1 (cddr form)))) + (dformat t "non-local return from block ~S~%" (block-name block))) + (let ((value-form (p1 (caddr form)))) + (push value-form (block-return-value-forms block)) + (list 'RETURN-FROM name value-form)))) (defun p1-tagbody (form) (let* ((block (make-tagbody-node)) Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Jan 6 12:26:32 2011 @@ -579,9 +579,27 @@ (defknown single-valued-p (t) t) (defun single-valued-p (form) (cond ((node-p form) - (if (tagbody-node-p form) - (not (unsafe-p (node-form form))) - (single-valued-p (node-form form)))) + (cond ((tagbody-node-p form) + t) + ((block-node-p form) + (and (single-valued-p (car (last (node-form form)))) + ;; return-from value forms + (every #'single-valued-p + (block-return-value-forms form)))) + ((or (flet-node-p form) + (labels-node-p form) + (let/let*-node-p form) + (m-v-b-node-p form) + (progv-node-p form) + (locally-node-p form) + (synchronized-node-p form)) + (single-valued-p (car (last (node-form form))))) + ((unwind-protect-node-p form) + (single-valued-p (second (node-form form)))) + ((catch-node-p form) + nil) + (t + (assert (not "SINGLE-VALUED-P unhandled NODE-P branch"))))) ((var-ref-p form) t) ((atom form) @@ -590,15 +608,15 @@ (let ((op (%car form)) result-type compiland) + (assert (not (member op '(LET LET* FLET LABELS TAGBODY CATCH + MULTIPLE-VALUE-BIND + UNWIND-PROTECT BLOCK PROGV + LOCALLY)))) (cond ((eq op 'IF) (and (single-valued-p (third form)) (single-valued-p (fourth form)))) ((eq op 'PROGN) (single-valued-p (car (last form)))) - ((eq op 'BLOCK) - (single-valued-p (car (last form)))) - ((memq op '(LET LET*)) - (single-valued-p (car (last (cddr form))))) ((memq op '(AND OR)) (every #'single-valued-p (cdr form))) ((eq op 'RETURN-FROM) Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp Thu Jan 6 12:26:32 2011 @@ -464,7 +464,10 @@ non-local-return-p ;; Contains a variable whose value uniquely identifies the ;; lexical scope from this block, to be used by RETURN-FROM - id-variable) + id-variable + ;; A list of all RETURN-FROM value forms associated with this block + return-value-forms) + (defknown make-block-node (t) t) (defun make-block-node (name) (let ((block (%make-block-node name))) From ehuelsmann at common-lisp.net Sun Jan 9 16:52:44 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 09 Jan 2011 11:52:44 -0500 Subject: [armedbear-cvs] r13130 - branches/0.24.x Message-ID: Author: ehuelsmann Date: Sun Jan 9 11:52:43 2011 New Revision: 13130 Log: Create 0.24.x release branch. Added: branches/0.24.x/ - copied from r13129, /trunk/ From ehuelsmann at common-lisp.net Sun Jan 9 16:54:39 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 09 Jan 2011 11:54:39 -0500 Subject: [armedbear-cvs] r13131 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 9 11:54:38 2011 New Revision: 13131 Log: With 0.24.x branched, increase trunk/ version number. Modified: trunk/abcl/src/org/armedbear/lisp/Version.java Modified: trunk/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Version.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Version.java Sun Jan 9 11:54:38 2011 @@ -41,7 +41,7 @@ public static String getVersion() { - return "0.24.0-dev"; + return "0.25.0-dev"; } public static void main(String args[]) { From ehuelsmann at common-lisp.net Mon Jan 10 21:26:54 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 10 Jan 2011 16:26:54 -0500 Subject: [armedbear-cvs] r13132 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jan 10 16:26:51 2011 New Revision: 13132 Log: Fix: When deleting a package it remains on the usedByList of the packages in its use list. Usually a package uses *at least* the CL package, meaning that packages don't get GC-ed. Modified: trunk/abcl/src/org/armedbear/lisp/Package.java Modified: trunk/abcl/src/org/armedbear/lisp/Package.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Package.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Package.java Mon Jan 10 16:26:51 2011 @@ -161,6 +161,13 @@ public final synchronized boolean delete() { if (name != null) { + LispObject usedPackages = useList; + while (usedPackages != NIL) { + Package pkg = (Package) usedPackages.car(); + unusePackage(pkg); + usedPackages = usedPackages.cdr(); + } + Packages.deletePackage(this); makeSymbolsUninterned(internalSymbols); From ehuelsmann at common-lisp.net Mon Jan 10 22:01:38 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 10 Jan 2011 17:01:38 -0500 Subject: [armedbear-cvs] r13133 - branches/0.24.x/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jan 10 17:01:37 2011 New Revision: 13133 Log: Backport r13132: fixed memory leak upon package deletion. Modified: branches/0.24.x/abcl/src/org/armedbear/lisp/Package.java Modified: branches/0.24.x/abcl/src/org/armedbear/lisp/Package.java ============================================================================== --- branches/0.24.x/abcl/src/org/armedbear/lisp/Package.java (original) +++ branches/0.24.x/abcl/src/org/armedbear/lisp/Package.java Mon Jan 10 17:01:37 2011 @@ -161,6 +161,13 @@ public final synchronized boolean delete() { if (name != null) { + LispObject usedPackages = useList; + while (usedPackages != NIL) { + Package pkg = (Package) usedPackages.car(); + unusePackage(pkg); + usedPackages = usedPackages.cdr(); + } + Packages.deletePackage(this); makeSymbolsUninterned(internalSymbols); From ehuelsmann at common-lisp.net Wed Jan 12 21:35:33 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 12 Jan 2011 16:35:33 -0500 Subject: [armedbear-cvs] r13134 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Jan 12 16:35:30 2011 New Revision: 13134 Log: Make sure symbols which have been assigned a specialIndex free their index when being garbage collected. Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java trunk/abcl/src/org/armedbear/lisp/Symbol.java Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispThread.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispThread.java Wed Jan 12 16:35:30 2011 @@ -37,6 +37,7 @@ import java.util.Iterator; import java.util.concurrent.ConcurrentHashMap; +import java.util.concurrent.ConcurrentLinkedQueue; import java.util.concurrent.atomic.AtomicInteger; public final class LispThread extends LispObject @@ -327,6 +328,12 @@ final static AtomicInteger lastSpecial = new AtomicInteger(UNASSIGNED_SPECIAL_INDEX); + /** A list of indices which can be (re)used for symbols to + * be assigned a special slot index. + */ + final static ConcurrentLinkedQueue freeSpecialIndices + = new ConcurrentLinkedQueue(); + /** This array stores the current special binding for every symbol * which has been globally or locally declared special. * @@ -335,12 +342,8 @@ * SpecialBinding object, but the value field of it is null, that * indicates an "UNBOUND VARIABLE" situation. */ - final SpecialBinding[] specials = new SpecialBinding[4097]; - - /** This array stores the symbols associated with the special - * bindings slots. - */ - final static Symbol[] specialNames = new Symbol[4097]; + final SpecialBinding[] specials + = new SpecialBinding[Integer.valueOf(System.getProperty("abcl.specials.initialSize","4096"))+1]; /** This variable points to the head of a linked list of saved * special bindings. Its main purpose is to allow a mark/reset @@ -387,9 +390,42 @@ synchronized (sym) { // Don't use an atomic access: we'll be swapping values only once. if (sym.specialIndex == 0) { - sym.specialIndex = lastSpecial.incrementAndGet(); - specialNames[sym.specialIndex] = sym; + Integer next = freeSpecialIndices.poll(); + if (next == null) + sym.specialIndex = lastSpecial.incrementAndGet(); + else + sym.specialIndex = next.intValue(); + } + } + } + + /** Frees up an index previously assigned to a symbol for re-assignment + * to another symbol. Returns without effect if the symbol has the + * default UNASSIGNED_SPECIAL_INDEX special index. + */ + protected static void releaseSpecialIndex(Symbol sym) + { + int index = sym.specialIndex; + if (index != UNASSIGNED_SPECIAL_INDEX) { + // clear out the values in the + Iterator it = map.values().iterator(); + while (it.hasNext()) { + LispThread thread = it.next(); + + // clear out the values in the saved specials list + SpecialBindingsMark savedSpecial = thread.savedSpecials; + while (savedSpecial != null) { + if (savedSpecial.idx == index) { + savedSpecial.idx = 0; + savedSpecial.binding = null; + } + savedSpecial = savedSpecial.next; + } + + thread.specials[index] = null; } + + freeSpecialIndices.add(new Integer(index)); } } 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 Wed Jan 12 16:35:30 2011 @@ -94,6 +94,17 @@ this.pkg = pkg; } + @Override + @SuppressWarnings("FinalizeDeclaration") + protected void finalize() throws Throwable { + try { + if (specialIndex != LispThread.UNASSIGNED_SPECIAL_INDEX) + LispThread.releaseSpecialIndex(this); + } finally { + super.finalize(); + } + } + @Override public LispObject typeOf() { From astalla at common-lisp.net Wed Jan 12 22:16:02 2011 From: astalla at common-lisp.net (Alessio Stalla) Date: Wed, 12 Jan 2011 17:16:02 -0500 Subject: [armedbear-cvs] r13135 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Wed Jan 12 17:16:01 2011 New Revision: 13135 Log: Revert to a reflection-based loading scheme for top-level compiled functions. Fix NPE in Package.java. Modified: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java trunk/abcl/src/org/armedbear/lisp/Package.java trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java (original) +++ trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java Wed Jan 12 17:16:01 2011 @@ -39,22 +39,12 @@ public class FaslClassLoader extends JavaClassLoader { - private final LispObject[] functions; private String baseName; private LispObject loader; //The function used to load FASL functions by number private final JavaObject boxedThis = new JavaObject(this); - - public FaslClassLoader(int functionCount, String baseName, boolean useLoaderFunction) { - functions = new LispObject[functionCount]; - this.baseName = baseName; - if(useLoaderFunction) { - try { - this.loader = (LispObject) loadClass(baseName + "_0").newInstance(); - } catch(Exception e) { - //e.printStackTrace(); - Debug.trace("useLoaderFunction = true but couldn't fully init FASL loader ("+baseName+"), will fall back to reflection!"); - } - } + + public FaslClassLoader(String baseName) { + this.baseName = baseName; } @Override @@ -90,81 +80,54 @@ @Override protected Class findClass(String name) throws ClassNotFoundException { - try { - byte[] b = getFunctionClassBytes(name); - return defineClass(name, b, 0, b.length); - } catch(Throwable e) { //TODO handle this better, readFunctionBytes uses Debug.assert() but should return null - e.printStackTrace(); - if(e instanceof ControlTransfer) { throw (ControlTransfer) e; } - throw new ClassNotFoundException("Function class not found: " + name, e); - } + try { + byte[] b = getFunctionClassBytes(name); + return defineClass(name, b, 0, b.length); + } catch(Throwable e) { //TODO handle this better, readFunctionBytes uses Debug.assert() but should return null + e.printStackTrace(); + if(e instanceof ControlTransfer) { throw (ControlTransfer) e; } + throw new ClassNotFoundException("Function class not found: " + name, e); + } } public byte[] getFunctionClassBytes(String name) { - Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + ".cls"); - return readFunctionBytes(pathname); + Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + ".cls"); + return readFunctionBytes(pathname); } public byte[] getFunctionClassBytes(Class functionClass) { - return getFunctionClassBytes(functionClass.getName()); + return getFunctionClassBytes(functionClass.getName()); } public byte[] getFunctionClassBytes(Function f) { - byte[] b = getFunctionClassBytes(f.getClass()); - f.setClassBytes(b); - return b; + byte[] b = getFunctionClassBytes(f.getClass()); + f.setClassBytes(b); + return b; } public LispObject loadFunction(int fnNumber) { - try { - //Function name is fnIndex + 1 - LispObject o = (LispObject) loadClass(baseName + "_" + (fnNumber + 1)).newInstance(); - functions[fnNumber] = o; - return o; - } catch(Exception e) { - e.printStackTrace(); - if(e instanceof ControlTransfer) { throw (ControlTransfer) e; } - throw new RuntimeException(e); - } - } - - public LispObject getFunction(int fnNumber) { - if(fnNumber >= functions.length) { - return error(new LispError("Compiled function not found: " + baseName + "_" + (fnNumber + 1) + " " + Symbol.LOAD_TRUENAME.symbolValue())); - } - LispObject o = functions[fnNumber]; - if(o == null) { - if(loader != null) { - loader.execute(boxedThis, Fixnum.getInstance(fnNumber)); - return functions[fnNumber]; - } else { //Fallback to reflection - return loadFunction(fnNumber); - } - } else { - return o; - } - } - - public LispObject putFunction(int fnNumber, LispObject fn) { - functions[fnNumber] = fn; - return fn; + try { + //Function name is fnIndex + 1 + LispObject o = (LispObject) loadClass(baseName + "_" + (fnNumber + 1)).newInstance(); + return o; + } catch(Exception e) { + if(e instanceof ControlTransfer) { throw (ControlTransfer) e; } + Debug.trace(e); + return error(new LispError("Compiled function can't be loaded: " + baseName + "_" + (fnNumber + 1) + " " + Symbol.LOAD_TRUENAME.symbolValue())); + } } private static final Primitive MAKE_FASL_CLASS_LOADER = new pf_make_fasl_class_loader(); private static final class pf_make_fasl_class_loader extends Primitive { - pf_make_fasl_class_loader() { - super("make-fasl-class-loader", PACKAGE_SYS, false, "function-count base-name"); + pf_make_fasl_class_loader() { + super("make-fasl-class-loader", PACKAGE_SYS, false, "base-name"); } @Override - public LispObject execute(LispObject functionCount, LispObject baseName) { - return execute(functionCount, baseName, T); + public LispObject execute(LispObject baseName) { + return new FaslClassLoader(baseName.getStringValue()).boxedThis; } - @Override - public LispObject execute(LispObject functionCount, LispObject baseName, LispObject init) { - return new FaslClassLoader(functionCount.intValue(), baseName.getStringValue(), init != NIL).boxedThis; - } }; private static final Primitive GET_FASL_FUNCTION = new pf_get_fasl_function(); @@ -176,7 +139,7 @@ @Override public LispObject execute(LispObject loader, LispObject fnNumber) { FaslClassLoader l = (FaslClassLoader) loader.javaInstance(FaslClassLoader.class); - return l.getFunction(fnNumber.intValue()); + return l.loadFunction(fnNumber.intValue()); } }; 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 Wed Jan 12 17:16:01 2011 @@ -161,11 +161,13 @@ public final synchronized boolean delete() { if (name != null) { - LispObject usedPackages = useList; - while (usedPackages != NIL) { - Package pkg = (Package) usedPackages.car(); - unusePackage(pkg); - usedPackages = usedPackages.cdr(); + if(useList instanceof Cons) { + LispObject usedPackages = useList; + while (usedPackages != NIL) { + Package pkg = (Package) usedPackages.car(); + unusePackage(pkg); + usedPackages = usedPackages.cdr(); + } } Packages.deletePackage(this); 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 Jan 12 17:16:01 2011 @@ -368,10 +368,8 @@ ;; however, binding *load-truename* isn't fully compliant, I think. (when compile-time-too (let ((*load-truename* *output-file-pathname*) - (*fasl-loader* (make-fasl-class-loader - *class-number* - (concatenate 'string "org.armedbear.lisp." (base-classname)) - nil))) + (*fasl-loader* (make-fasl-class-loader + (concatenate 'string "org.armedbear.lisp." (base-classname))))) (eval form)))) (declaim (ftype (function (t) t) convert-ensure-method)) @@ -611,10 +609,8 @@ (%stream-terpri out) (when (> *class-number* 0) - (generate-loader-function) (write (list 'setq '*fasl-loader* `(sys::make-fasl-class-loader - ,*class-number* ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out)) (%stream-terpri out)) @@ -661,62 +657,6 @@ (namestring output-file) elapsed)))) (values (truename output-file) warnings-p failure-p))) -(defmacro ncase (expr min max &rest clauses) - "A CASE where all test clauses are numbers ranging from a minimum to a maximum." - ;;Expr is subject to multiple evaluation, but since we only use ncase for - ;;fn-index below, let's ignore it. - (let* ((half (floor (/ (- max min) 2))) - (middle (+ min half))) - (if (> (- max min) 10) - `(if (< ,expr ,middle) - (ncase ,expr ,min ,middle ,@(subseq clauses 0 half)) - (ncase ,expr ,middle ,max ,@(subseq clauses half))) - `(case ,expr , at clauses)))) - -(defconstant +fasl-classloader+ - (jvm::make-jvm-class-name "org.armedbear.lisp.FaslClassLoader")) - -(defun generate-loader-function () - (let* ((basename (base-classname)) - (expr `(lambda (fasl-loader fn-index) - (declare (type (integer 0 256000) fn-index)) - (identity fasl-loader) ;;to avoid unused arg - (jvm::with-inline-code () - (jvm::emit 'jvm::aload 1) - (jvm::emit-invokevirtual jvm::+lisp-object+ "javaInstance" - nil jvm::+java-object+) - (jvm::emit-checkcast +fasl-classloader+) - (jvm::emit 'jvm::iload 2)) - (ncase fn-index 0 ,(1- *class-number*) - ,@(loop - :for i :from 1 :to *class-number* - :collect - (let* ((class (%format nil "org/armedbear/lisp/~A_~A" - basename i)) - (class-name (jvm::make-jvm-class-name class))) - `(,(1- i) - (jvm::with-inline-code () - (jvm::emit-new ,class-name) - (jvm::emit 'jvm::dup) - (jvm::emit-invokespecial-init ,class-name '()) - (jvm::emit-invokevirtual +fasl-classloader+ - "putFunction" - (list :int jvm::+lisp-object+) jvm::+lisp-object+) - (jvm::emit 'jvm::pop)) - t)))))) - (classname (fasl-loader-classname)) - (classfile (namestring (merge-pathnames (make-pathname :name classname :type "cls") - *output-file-pathname*)))) - (jvm::with-saved-compiler-policy - (jvm::with-file-compilation - (with-open-file - (f classfile - :direction :output - :element-type '(unsigned-byte 8) - :if-exists :supersede) - (jvm:compile-defun nil expr *compile-file-environment* - classfile f nil)))))) - (defun compile-file-if-needed (input-file &rest allargs &key force-compile &allow-other-keys) (setf input-file (truename input-file)) From ehuelsmann at common-lisp.net Wed Jan 12 22:29:16 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 12 Jan 2011 17:29:16 -0500 Subject: [armedbear-cvs] r13136 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Jan 12 17:29:15 2011 New Revision: 13136 Log: When a special bindings index has been assigned past the end of the special bindings array, grow the array until it fits. Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispThread.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispThread.java Wed Jan 12 17:29:15 2011 @@ -342,9 +342,15 @@ * SpecialBinding object, but the value field of it is null, that * indicates an "UNBOUND VARIABLE" situation. */ - final SpecialBinding[] specials + SpecialBinding[] specials = new SpecialBinding[Integer.valueOf(System.getProperty("abcl.specials.initialSize","4096"))+1]; + /** The number of slots to grow the specials table in + * case of insufficient storage. + */ + final int specialsDelta + = Integer.valueOf(System.getProperty("abcl.specials.grow.delta","1024")); + /** This variable points to the head of a linked list of saved * special bindings. Its main purpose is to allow a mark/reset * interface to special binding and unbinding. @@ -382,7 +388,7 @@ /** Assigns a specials array index number to the symbol, * if it doesn't already have one. */ - private static final void assignSpecialIndex(Symbol sym) + private void assignSpecialIndex(Symbol sym) { if (sym.specialIndex != 0) return; @@ -391,6 +397,13 @@ // Don't use an atomic access: we'll be swapping values only once. if (sym.specialIndex == 0) { Integer next = freeSpecialIndices.poll(); + if (next == null + && specials.length < lastSpecial.get() + && null == System.getProperty("abcl.specials.grow.slowly")) { + // free slots are exhausted; in the middle and at the end. + System.gc(); + next = freeSpecialIndices.poll(); + } if (next == null) sym.specialIndex = lastSpecial.incrementAndGet(); else @@ -429,12 +442,36 @@ } } + private void growSpecials() { + SpecialBinding[] newSpecials + = new SpecialBinding[specials.length + specialsDelta]; + System.arraycopy(specials, 0, newSpecials, 0, specials.length); + specials = newSpecials; + } + + private SpecialBinding ensureSpecialBinding(int idx) { + SpecialBinding binding; + boolean assigned; + do { + try { + binding = specials[idx]; + assigned = true; + } + catch (ArrayIndexOutOfBoundsException e) { + assigned = false; + binding = null; // suppresses 'unassigned' error + growSpecials(); + } + } while (! assigned); + return binding; + } + public final SpecialBinding bindSpecial(Symbol name, LispObject value) { int idx; assignSpecialIndex(name); - SpecialBinding binding = specials[idx = name.specialIndex]; + SpecialBinding binding = ensureSpecialBinding(idx = name.specialIndex); savedSpecials = new SpecialBindingsMark(idx, binding, savedSpecials); return specials[idx] = new SpecialBinding(idx, value); } @@ -444,7 +481,7 @@ int idx; assignSpecialIndex(name); - SpecialBinding binding = specials[idx = name.specialIndex]; + SpecialBinding binding = ensureSpecialBinding(idx = name.specialIndex); savedSpecials = new SpecialBindingsMark(idx, binding, savedSpecials); return specials[idx] = new SpecialBinding(idx, @@ -465,18 +502,18 @@ */ public final LispObject lookupSpecial(Symbol name) { - SpecialBinding binding = specials[name.specialIndex]; + SpecialBinding binding = ensureSpecialBinding(name.specialIndex); return (binding == null) ? null : binding.value; } public final SpecialBinding getSpecialBinding(Symbol name) { - return specials[name.specialIndex]; + return ensureSpecialBinding(name.specialIndex); } public final LispObject setSpecialVariable(Symbol name, LispObject value) { - SpecialBinding binding = specials[name.specialIndex]; + SpecialBinding binding = ensureSpecialBinding(name.specialIndex); if (binding != null) return binding.value = value; @@ -487,7 +524,7 @@ public final LispObject pushSpecial(Symbol name, LispObject thing) { - SpecialBinding binding = specials[name.specialIndex]; + SpecialBinding binding = ensureSpecialBinding(name.specialIndex); if (binding != null) return binding.value = new Cons(thing, binding.value); @@ -503,7 +540,7 @@ // Returns symbol value or NIL if unbound. public final LispObject safeSymbolValue(Symbol name) { - SpecialBinding binding = specials[name.specialIndex]; + SpecialBinding binding = ensureSpecialBinding(name.specialIndex); if (binding != null) return binding.value; From ehuelsmann at common-lisp.net Thu Jan 13 20:55:03 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 13 Jan 2011 15:55:03 -0500 Subject: [armedbear-cvs] r13137 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jan 13 15:54:59 2011 New Revision: 13137 Log: Unbreak trunk compilation. We need the specialNames after all. Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java trunk/abcl/src/org/armedbear/lisp/SpecialBinding.java Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispThread.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispThread.java Thu Jan 13 15:54:59 2011 @@ -33,6 +33,7 @@ package org.armedbear.lisp; +import java.lang.ref.WeakReference; import static org.armedbear.lisp.Lisp.*; import java.util.Iterator; @@ -333,7 +334,10 @@ */ final static ConcurrentLinkedQueue freeSpecialIndices = new ConcurrentLinkedQueue(); - + + final static int specialsInitialSize + = Integer.valueOf(System.getProperty("abcl.specials.initialSize","4096")); + /** This array stores the current special binding for every symbol * which has been globally or locally declared special. * @@ -343,12 +347,15 @@ * indicates an "UNBOUND VARIABLE" situation. */ SpecialBinding[] specials - = new SpecialBinding[Integer.valueOf(System.getProperty("abcl.specials.initialSize","4096"))+1]; + = new SpecialBinding[specialsInitialSize + 1]; + + final static ConcurrentHashMap> specialNames + = new ConcurrentHashMap>(); /** The number of slots to grow the specials table in * case of insufficient storage. */ - final int specialsDelta + final static int specialsDelta = Integer.valueOf(System.getProperty("abcl.specials.grow.delta","1024")); /** This variable points to the head of a linked list of saved Modified: trunk/abcl/src/org/armedbear/lisp/SpecialBinding.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SpecialBinding.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SpecialBinding.java Thu Jan 13 15:54:59 2011 @@ -59,7 +59,7 @@ { if (value == null) // return or not: error doesn't return anyway - Lisp.error(new UnboundVariable(LispThread.specialNames[idx])); + Lisp.error(new UnboundVariable(LispThread.specialNames.get(new Integer(idx)).get())); return value; } From ehuelsmann at common-lisp.net Thu Jan 13 21:06:18 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 13 Jan 2011 16:06:18 -0500 Subject: [armedbear-cvs] r13138 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jan 13 16:06:17 2011 New Revision: 13138 Log: Remove unused function. Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.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 Thu Jan 13 16:06:17 2011 @@ -429,11 +429,6 @@ thread.printBacktrace(); } - public void kill() - { - kill(0); - } - public void kill(int status) { if (jlisp) { From ehuelsmann at common-lisp.net Thu Jan 13 21:15:27 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 13 Jan 2011 16:15:27 -0500 Subject: [armedbear-cvs] r13139 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jan 13 16:15:26 2011 New Revision: 13139 Log: Adjust indenting and add a SuppressWarning annotation. 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 Thu Jan 13 16:15:26 2011 @@ -1581,6 +1581,7 @@ } @Override + @SuppressWarnings("CallToThreadDumpStack") public LispObject execute(LispObject[] args) { Error e = new Error(); @@ -1592,8 +1593,8 @@ System.out.println(args[0].writeToString()); System.out.println(((Condition)args[0]).getConditionReport()); } else -for (LispObject a : args) - System.out.println(a.writeToString()); + for (LispObject a : args) + System.out.println(a.writeToString()); //###FIXME: Bail out, but do it nicer... exit(1); From ehuelsmann at common-lisp.net Thu Jan 13 21:20:48 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 13 Jan 2011 16:20:48 -0500 Subject: [armedbear-cvs] r13140 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jan 13 16:20:47 2011 New Revision: 13140 Log: Add missing subversion properties. Modified: trunk/abcl/src/org/armedbear/lisp/InternalCompilerError.java (contents, props changed) Modified: trunk/abcl/src/org/armedbear/lisp/InternalCompilerError.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/InternalCompilerError.java (original) +++ trunk/abcl/src/org/armedbear/lisp/InternalCompilerError.java Thu Jan 13 16:20:47 2011 @@ -2,7 +2,7 @@ * InternalCompilerError.java * * Copyright (C) 2005 Peter Graves - * $Id: CompilerError.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 ehuelsmann at common-lisp.net Thu Jan 13 22:06:55 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 13 Jan 2011 17:06:55 -0500 Subject: [armedbear-cvs] r13141 - trunk/abcl/src/org/armedbear/lisp/java/swing Message-ID: Author: ehuelsmann Date: Thu Jan 13 17:06:55 2011 New Revision: 13141 Log: Replace Lisp.exit() with System.exit() in REPLConsole; no functional change. Modified: trunk/abcl/src/org/armedbear/lisp/java/swing/REPLConsole.java Modified: trunk/abcl/src/org/armedbear/lisp/java/swing/REPLConsole.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/java/swing/REPLConsole.java (original) +++ trunk/abcl/src/org/armedbear/lisp/java/swing/REPLConsole.java Thu Jan 13 17:06:55 2011 @@ -302,7 +302,7 @@ repl = Interpreter.createInstance().eval("#'top-level::top-level-loop"); } catch (Throwable e) { e.printStackTrace(); - exit(1); + System.exit(1); } final REPLConsole d = new REPLConsole(repl); final JTextComponent txt = new JTextArea(d); From ehuelsmann at common-lisp.net Thu Jan 13 22:29:41 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 13 Jan 2011 17:29:41 -0500 Subject: [armedbear-cvs] r13142 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jan 13 17:29:41 2011 New Revision: 13142 Log: Mark exit() invocations as FIXME. I'll address later. Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.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 Thu Jan 13 17:29:41 2011 @@ -89,7 +89,7 @@ Stream out = getStandardOutput(); out._writeString(help()); out._finishOutput(); - exit(0); + exit(0); // FIXME } if (noinform) _NOINFORM_.setSymbolValue(T); @@ -253,7 +253,7 @@ ++i; } else { System.err.println("No argument supplied to --eval"); - exit(1); + exit(1); // FIXME } } else if (arg.equals("--load") || arg.equals("--load-system-file")) { @@ -261,7 +261,7 @@ ++i; } else { System.err.println("No argument supplied to --load"); - exit(1); + exit(1); // FIXME } } else { arglist = new Cons(args[i], arglist); @@ -301,13 +301,13 @@ sb.append(c.getCondition().writeToString()); sb.append(separator); System.err.print(sb.toString()); - exit(2); + exit(2); // FIXME } ++i; } else { // Shouldn't happen. System.err.println("No argument supplied to --eval"); - exit(1); + exit(1); // FIXME } } else if (arg.equals("--load") || arg.equals("--load-system-file")) { @@ -322,13 +322,13 @@ } else { // Shouldn't happen. System.err.println("No argument supplied to --load"); - exit(1); + exit(1); // FIXME } } } } if (_BATCH_MODE_.getSymbolValue() == T) { - exit(0); + exit(0); // FIXME } } From ehuelsmann at common-lisp.net Thu Jan 13 22:49:29 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 13 Jan 2011 17:49:29 -0500 Subject: [armedbear-cvs] r13143 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jan 13 17:49:28 2011 New Revision: 13143 Log: Add IntegrityError and ProcessingTerminated error classes and adjust Interpreter.run() accordingly. No longer call (directly or indirectly) System.exit(), throw the relevant errors instead. Added: trunk/abcl/src/org/armedbear/lisp/IntegrityError.java - copied, changed from r13136, /trunk/abcl/src/org/armedbear/lisp/ThreadDestroyed.java trunk/abcl/src/org/armedbear/lisp/ProcessingTerminated.java - copied, changed from r13136, /trunk/abcl/src/org/armedbear/lisp/ThreadDestroyed.java Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/Extensions.java trunk/abcl/src/org/armedbear/lisp/Interpreter.java trunk/abcl/src/org/armedbear/lisp/Main.java trunk/abcl/src/org/armedbear/lisp/Primitives.java Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Thu Jan 13 17:49:28 2011 @@ -141,7 +141,7 @@ if (symbol != null) { if (symbol.getSymbolFunction() instanceof Autoload) { Debug.trace("Unable to autoload " + symbol.writeToString()); - System.exit(-1); + throw new IntegrityError(); } } } 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 Thu Jan 13 17:49:28 2011 @@ -200,8 +200,7 @@ @Override public LispObject execute() { - exit(0); - return LispThread.currentThread().nothing(); + throw new ProcessingTerminated(); } @Override public LispObject execute(LispObject first, LispObject second) @@ -213,8 +212,7 @@ if (second instanceof Fixnum) status = ((Fixnum)second).value; } - exit(status); - return LispThread.currentThread().nothing(); + throw new ProcessingTerminated(status); } } @@ -229,8 +227,7 @@ { ((Stream)Symbol.STANDARD_OUTPUT.getSymbolValue())._finishOutput(); ((Stream)Symbol.ERROR_OUTPUT.getSymbolValue())._finishOutput(); - exit(0); - return LispThread.currentThread().nothing(); + throw new ProcessingTerminated(); } @Override public LispObject execute(LispObject first, LispObject second) @@ -241,8 +238,7 @@ if (second instanceof Fixnum) status = ((Fixnum)second).value; } - exit(status); - return LispThread.currentThread().nothing(); + throw new ProcessingTerminated(status); } } Copied: trunk/abcl/src/org/armedbear/lisp/IntegrityError.java (from r13136, /trunk/abcl/src/org/armedbear/lisp/ThreadDestroyed.java) ============================================================================== --- /trunk/abcl/src/org/armedbear/lisp/ThreadDestroyed.java (original) +++ trunk/abcl/src/org/armedbear/lisp/IntegrityError.java Thu Jan 13 17:49:28 2011 @@ -1,7 +1,7 @@ /* - * ThreadDestroyed.java + * IntegrityError.java * - * Copyright (C) 2003 Peter Graves + * Copyright (C) 2011 Erik Huelsmann * $Id$ * * This program is free software; you can redistribute it and/or @@ -33,9 +33,9 @@ package org.armedbear.lisp; -public class ThreadDestroyed extends Error +public class IntegrityError extends Error { - public ThreadDestroyed() + public IntegrityError() { } 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 Thu Jan 13 17:49:28 2011 @@ -332,6 +332,7 @@ } } + @SuppressWarnings("CallToThreadDumpStack") public void run() { final LispThread thread = LispThread.currentThread(); @@ -342,66 +343,74 @@ thread.execute(tplFun); return; } - // We only arrive here if something went wrong and we weren't able - // to load top-level.lisp and run the normal top-level loop. - Stream out = getStandardOutput(); - while (true) { - try { - thread.resetStack(); - thread.clearSpecialBindings(); - out._writeString("* "); - out._finishOutput(); - LispObject object = - getStandardInput().read(false, EOF, false, thread, - Stream.currentReadtable); - if (object == EOF) - break; - out.setCharPos(0); - Symbol.MINUS.setSymbolValue(object); - LispObject result = Lisp.eval(object, new Environment(), thread); - Debug.assertTrue(result != null); - Symbol.STAR_STAR_STAR.setSymbolValue(Symbol.STAR_STAR.getSymbolValue()); - Symbol.STAR_STAR.setSymbolValue(Symbol.STAR.getSymbolValue()); - Symbol.STAR.setSymbolValue(result); - Symbol.PLUS_PLUS_PLUS.setSymbolValue(Symbol.PLUS_PLUS.getSymbolValue()); - Symbol.PLUS_PLUS.setSymbolValue(Symbol.PLUS.getSymbolValue()); - Symbol.PLUS.setSymbolValue(Symbol.MINUS.getSymbolValue()); - out = getStandardOutput(); - out.freshLine(); - LispObject[] values = thread.getValues(); - Symbol.SLASH_SLASH_SLASH.setSymbolValue(Symbol.SLASH_SLASH.getSymbolValue()); - Symbol.SLASH_SLASH.setSymbolValue(Symbol.SLASH.getSymbolValue()); - if (values != null) { - LispObject slash = NIL; - for (int i = values.length; i-- > 0;) - slash = new Cons(values[i], slash); - Symbol.SLASH.setSymbolValue(slash); - for (int i = 0; i < values.length; i++) - out._writeLine(values[i].writeToString()); - } else { - Symbol.SLASH.setSymbolValue(new Cons(result)); - out._writeLine(result.writeToString()); - } - out._finishOutput(); - } - catch (StackOverflowError e) { - getStandardInput().clearInput(); - out._writeLine("Stack overflow"); - } - catch (ControlTransfer c) { - // We're on the toplevel, if this occurs, - // we're toast... - reportError(c, thread); - } - catch (Throwable t) { - getStandardInput().clearInput(); - out.printStackTrace(t); - thread.printBacktrace(); - } - } + } + catch (ProcessingTerminated e) { + throw e; + } + catch (IntegrityError e) { + return; } catch (Throwable t) { t.printStackTrace(); + return; + } + + // We only arrive here if something went wrong and we weren't able + // to load top-level.lisp and run the normal top-level loop. + Stream out = getStandardOutput(); + while (true) { + try { + thread.resetStack(); + thread.clearSpecialBindings(); + out._writeString("* "); + out._finishOutput(); + LispObject object = + getStandardInput().read(false, EOF, false, thread, + Stream.currentReadtable); + if (object == EOF) + break; + out.setCharPos(0); + Symbol.MINUS.setSymbolValue(object); + LispObject result = Lisp.eval(object, new Environment(), thread); + Debug.assertTrue(result != null); + Symbol.STAR_STAR_STAR.setSymbolValue(Symbol.STAR_STAR.getSymbolValue()); + Symbol.STAR_STAR.setSymbolValue(Symbol.STAR.getSymbolValue()); + Symbol.STAR.setSymbolValue(result); + Symbol.PLUS_PLUS_PLUS.setSymbolValue(Symbol.PLUS_PLUS.getSymbolValue()); + Symbol.PLUS_PLUS.setSymbolValue(Symbol.PLUS.getSymbolValue()); + Symbol.PLUS.setSymbolValue(Symbol.MINUS.getSymbolValue()); + out = getStandardOutput(); + out.freshLine(); + LispObject[] values = thread.getValues(); + Symbol.SLASH_SLASH_SLASH.setSymbolValue(Symbol.SLASH_SLASH.getSymbolValue()); + Symbol.SLASH_SLASH.setSymbolValue(Symbol.SLASH.getSymbolValue()); + if (values != null) { + LispObject slash = NIL; + for (int i = values.length; i-- > 0;) + slash = new Cons(values[i], slash); + Symbol.SLASH.setSymbolValue(slash); + for (int i = 0; i < values.length; i++) + out._writeLine(values[i].writeToString()); + } else { + Symbol.SLASH.setSymbolValue(new Cons(result)); + out._writeLine(result.writeToString()); + } + out._finishOutput(); + } + catch (StackOverflowError e) { + getStandardInput().clearInput(); + out._writeLine("Stack overflow"); + } + catch (ControlTransfer c) { + // We're on the toplevel, if this occurs, + // we're toast... + reportError(c, thread); + } + catch (Throwable t) { + getStandardInput().clearInput(); + out.printStackTrace(t); + thread.printBacktrace(); + } } } Modified: trunk/abcl/src/org/armedbear/lisp/Main.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Main.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Main.java Thu Jan 13 17:49:28 2011 @@ -30,26 +30,29 @@ * obligated to do so. If you do not wish to do so, delete this * exception statement from your version. */ - package org.armedbear.lisp; -public final class Main -{ - public static final long startTimeMillis = System.currentTimeMillis(); +public final class Main { + + public static final long startTimeMillis = System.currentTimeMillis(); + + public static void main(final String[] args) { + // Run the interpreter in a secondary thread so we can control the stack + // size. + Runnable r = new Runnable() { + + public void run() { + Interpreter interpreter = Interpreter.createDefaultInstance(args); + if (interpreter != null) { + try { + interpreter.run(); + } catch (ProcessingTerminated e) { + System.exit(e.getStatus()); + } - public static void main(final String[] args) - { - // Run the interpreter in a secondary thread so we can control the stack - // size. - Runnable r = new Runnable() - { - public void run() - { - Interpreter interpreter = Interpreter.createDefaultInstance(args); - if (interpreter != null) - interpreter.run(); - } - }; - new Thread(null, r, "interpreter", 4194304L).start(); - } + } + } + }; + new Thread(null, r, "interpreter", 4194304L).start(); + } } 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 Thu Jan 13 17:49:28 2011 @@ -1583,7 +1583,7 @@ @Override @SuppressWarnings("CallToThreadDumpStack") public LispObject execute(LispObject[] args) { - Error e = new Error(); + Error e = new IntegrityError(); e.printStackTrace(); @@ -1596,9 +1596,7 @@ for (LispObject a : args) System.out.println(a.writeToString()); - //###FIXME: Bail out, but do it nicer... - exit(1); - return NIL; + throw e; } }; Copied: trunk/abcl/src/org/armedbear/lisp/ProcessingTerminated.java (from r13136, /trunk/abcl/src/org/armedbear/lisp/ThreadDestroyed.java) ============================================================================== --- /trunk/abcl/src/org/armedbear/lisp/ThreadDestroyed.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ProcessingTerminated.java Thu Jan 13 17:49:28 2011 @@ -1,7 +1,7 @@ /* - * ThreadDestroyed.java + * ProcessingTerminated.java * - * Copyright (C) 2003 Peter Graves + * Copyright (C) 2011 Erik Huelsmann * $Id$ * * This program is free software; you can redistribute it and/or @@ -33,10 +33,20 @@ package org.armedbear.lisp; -public class ThreadDestroyed extends Error +public class ProcessingTerminated extends Error { - public ThreadDestroyed() + private int status; + + public ProcessingTerminated() { } + public ProcessingTerminated(int status) + { + this.status = status; + } + + int getStatus() { + return status; + } } From ehuelsmann at common-lisp.net Thu Jan 13 23:19:23 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 13 Jan 2011 18:19:23 -0500 Subject: [armedbear-cvs] r13144 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jan 13 18:19:22 2011 New Revision: 13144 Log: Stabilize the new way of terminating ABCL. Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Main.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 Thu Jan 13 18:19:22 2011 @@ -406,6 +406,12 @@ // we're toast... reportError(c, thread); } + catch (ProcessingTerminated e) { + throw e; + } + catch (IntegrityError e) { + return; + } catch (Throwable t) { getStandardInput().clearInput(); out.printStackTrace(t); 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 Thu Jan 13 18:19:22 2011 @@ -289,6 +289,14 @@ { throw c; } + catch (ProcessingTerminated c) + { + throw c; + } + catch (IntegrityError c) + { + throw c; + } catch (Throwable t) // ControlTransfer handled above { Debug.trace(t); Modified: trunk/abcl/src/org/armedbear/lisp/Main.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Main.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Main.java Thu Jan 13 18:19:22 2011 @@ -42,14 +42,12 @@ Runnable r = new Runnable() { public void run() { - Interpreter interpreter = Interpreter.createDefaultInstance(args); - if (interpreter != null) { - try { - interpreter.run(); - } catch (ProcessingTerminated e) { - System.exit(e.getStatus()); - } - + try { + Interpreter interpreter = Interpreter.createDefaultInstance(args); + if (interpreter != null) + interpreter.run(); + } catch (ProcessingTerminated e) { + System.exit(e.getStatus()); } } }; From ehuelsmann at common-lisp.net Thu Jan 13 23:20:20 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 13 Jan 2011 18:20:20 -0500 Subject: [armedbear-cvs] r13145 - trunk/abcl/src/org/armedbear/lisp/java/swing Message-ID: Author: ehuelsmann Date: Thu Jan 13 18:20:19 2011 New Revision: 13145 Log: Comment why System.exit() is alright in the REPLConsole.java case. Modified: trunk/abcl/src/org/armedbear/lisp/java/swing/REPLConsole.java Modified: trunk/abcl/src/org/armedbear/lisp/java/swing/REPLConsole.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/java/swing/REPLConsole.java (original) +++ trunk/abcl/src/org/armedbear/lisp/java/swing/REPLConsole.java Thu Jan 13 18:20:19 2011 @@ -302,7 +302,7 @@ repl = Interpreter.createInstance().eval("#'top-level::top-level-loop"); } catch (Throwable e) { e.printStackTrace(); - System.exit(1); + System.exit(1); // Ok. We haven't done anything useful yet. } final REPLConsole d = new REPLConsole(repl); final JTextComponent txt = new JTextArea(d); From ehuelsmann at common-lisp.net Fri Jan 14 09:43:44 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 14 Jan 2011 04:43:44 -0500 Subject: [armedbear-cvs] r13146 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Jan 14 04:43:43 2011 New Revision: 13146 Log: Add class documentation for recently added classes. Modified: trunk/abcl/src/org/armedbear/lisp/IntegrityError.java trunk/abcl/src/org/armedbear/lisp/ProcessingTerminated.java Modified: trunk/abcl/src/org/armedbear/lisp/IntegrityError.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/IntegrityError.java (original) +++ trunk/abcl/src/org/armedbear/lisp/IntegrityError.java Fri Jan 14 04:43:43 2011 @@ -33,6 +33,10 @@ package org.armedbear.lisp; +/** This error is invoked in situations where the code can't continue + * because some precondition isn't met, although it's not an assertion + * error per se. + */ public class IntegrityError extends Error { public IntegrityError() Modified: trunk/abcl/src/org/armedbear/lisp/ProcessingTerminated.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ProcessingTerminated.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ProcessingTerminated.java Fri Jan 14 04:43:43 2011 @@ -33,6 +33,12 @@ package org.armedbear.lisp; +/** This error is thrown when the EXT:EXIT or EXT:QUIT function + * is being invoked. In the stand-alone case, it terminates the + * entire JVM, if caught in Interpreter.run(). + * + * In the embedding case, it's up to the embedder what to do with it. + */ public class ProcessingTerminated extends Error { private int status; From ehuelsmann at common-lisp.net Fri Jan 14 15:57:40 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 14 Jan 2011 10:57:40 -0500 Subject: [armedbear-cvs] r13147 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Jan 14 10:57:37 2011 New Revision: 13147 Log: Set the COMPILAND-%SINGLE-VALUED-P field after the full analysis of the compiland's source form, instead of setting it to T if *any* non-single-valued function is called. 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 Jan 14 10:57:37 2011 @@ -1289,39 +1289,30 @@ (return-from p1-function-call (p1 new-form)))) (let* ((op (car form)) (local-function (find-local-function op))) - (cond (local-function + (when 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)) - (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 - (let ((*inline-declarations* - (remove op *inline-declarations* :key #'car :test #'equal))) - (p1 expansion)))))) - - ;; FIXME - (dformat t "local function assumed not single-valued~%") - (setf (compiland-%single-valued-p *current-compiland*) nil) - - (let ((variable (local-function-variable local-function))) - (when variable - (dformat t "p1 ~S used non-locally~%" (variable-name variable)) - (setf (variable-used-non-locally-p variable) t)))) - (t - ;; Not a local function call. - (dformat t "p1 non-local call to ~S~%" op) - (unless (single-valued-p form) -;; (format t "not single-valued op = ~S~%" op) - (setf (compiland-%single-valued-p *current-compiland*) nil))))) + + (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 + (let ((*inline-declarations* + (remove op *inline-declarations* :key #'car :test #'equal))) + (p1 expansion)))))) + + (let ((variable (local-function-variable local-function))) + (when variable + (dformat t "p1 ~S used non-locally~%" (variable-name variable)) + (setf (variable-used-non-locally-p variable) t))))) (p1-default form)) (defun %funcall (fn &rest args) @@ -1457,7 +1448,8 @@ (*visible-variables* *visible-variables*) (closure (make-closure `(lambda ,lambda-list nil) nil)) (syms (sys::varlist closure)) - (vars nil)) + (vars nil) + compiland-result) (dolist (sym syms) (let ((var (make-variable :name sym :special-p (special-variable-p sym)))) @@ -1469,7 +1461,11 @@ (setf (compiland-free-specials compiland) free-specials) (dolist (var free-specials) (push var *visible-variables*))) + (setf compiland-result + (list* 'LAMBDA lambda-list (p1-body body))) + (setf (compiland-%single-valued-p compiland) + (single-valued-p compiland-result)) (setf (compiland-p1-result compiland) - (list* 'LAMBDA lambda-list (p1-body body)))))) + compiland-result)))) (provide "COMPILER-PASS1") From astalla at common-lisp.net Fri Jan 14 20:24:19 2011 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 14 Jan 2011 15:24:19 -0500 Subject: [armedbear-cvs] r13148 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Fri Jan 14 15:24:18 2011 New Revision: 13148 Log: Restored disassembly for compiled functions loaded from FASLs by always storing the class bytes greedily. Modified: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java Modified: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java (original) +++ trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java Fri Jan 14 15:24:18 2011 @@ -39,8 +39,7 @@ public class FaslClassLoader extends JavaClassLoader { - private String baseName; - private LispObject loader; //The function used to load FASL functions by number + private final String baseName; private final JavaObject boxedThis = new JavaObject(this); public FaslClassLoader(String baseName) { @@ -63,13 +62,13 @@ String internalName = "org/armedbear/lisp/" + name; Class c = this.findLoadedClass(internalName); - if (c == null) + if (c == null) { c = findClass(name); - + } if (c != null) { - if (resolve) + if (resolve) { resolveClass(c); - + } return c; } } @@ -94,7 +93,7 @@ Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + ".cls"); return readFunctionBytes(pathname); } - + public byte[] getFunctionClassBytes(Class functionClass) { return getFunctionClassBytes(functionClass.getName()); } @@ -108,8 +107,10 @@ public LispObject loadFunction(int fnNumber) { try { //Function name is fnIndex + 1 - LispObject o = (LispObject) loadClass(baseName + "_" + (fnNumber + 1)).newInstance(); - return o; + String name = baseName + "_" + (fnNumber + 1); + Function f = (Function) loadClass(name).newInstance(); + f.setClassBytes(getFunctionClassBytes(name)); + return f; } catch(Exception e) { if(e instanceof ControlTransfer) { throw (ControlTransfer) e; } Debug.trace(e); From astalla at common-lisp.net Fri Jan 14 21:12:31 2011 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 14 Jan 2011 16:12:31 -0500 Subject: [armedbear-cvs] r13149 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Fri Jan 14 16:12:30 2011 New Revision: 13149 Log: Keep sys::make-fasl-class-loader API compatible to avoid changing the FASL version number. Modified: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java (original) +++ trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java Fri Jan 14 16:12:30 2011 @@ -129,6 +129,12 @@ return new FaslClassLoader(baseName.getStringValue()).boxedThis; } + @Override + //TODO delete this next time the fasl version is bumbed + public LispObject execute(LispObject unused1, LispObject baseName, LispObject unused2) { + return execute(baseName); + } + }; private static final Primitive GET_FASL_FUNCTION = new pf_get_fasl_function(); 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 Jan 14 16:12:30 2011 @@ -1292,6 +1292,7 @@ try { if (input == null) { Debug.trace("Pathname: " + name); + Debug.trace("load: " + load); Debug.trace("LOAD_TRUENAME_FASL: " + truenameFasl); Debug.trace("LOAD_TRUENAME: " + truename); Debug.assertTrue(input != null); 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 Fri Jan 14 16:12:30 2011 @@ -342,6 +342,14 @@ // ### *fasl-version* // internal symbol + + /* TODO when bumping the version for any reason, remember to: + * - remove the overload taking 3 args in + * FaslClassLoader.MAKE_FASL_CLASS_LOADER + * - remove the extra args (1 and 3, both NIL) passed to + * make-fasl-class-loader in compile-file.lisp + * - delete this comment :) + */ static final Symbol _FASL_VERSION_ = exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(37)); 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 Fri Jan 14 16:12:30 2011 @@ -369,7 +369,9 @@ (when compile-time-too (let ((*load-truename* *output-file-pathname*) (*fasl-loader* (make-fasl-class-loader - (concatenate 'string "org.armedbear.lisp." (base-classname))))) + nil + (concatenate 'string "org.armedbear.lisp." (base-classname)) + nil))) (eval form)))) (declaim (ftype (function (t) t) convert-ensure-method)) @@ -611,7 +613,9 @@ (when (> *class-number* 0) (write (list 'setq '*fasl-loader* `(sys::make-fasl-class-loader - ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out)) + nil + ,(concatenate 'string "org.armedbear.lisp." (base-classname)) + nil)) :stream out)) (%stream-terpri out)) @@ -620,7 +624,7 @@ while (not (eq line :eof)) do (write-line line out)))) (delete-file temp-file) - (remove-zip-cache-entry output-file) ;; Necessary under windows + (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 Sat Jan 15 19:49:32 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 15 Jan 2011 14:49:32 -0500 Subject: [armedbear-cvs] r13150 - branches/unsafe-p-removal/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jan 15 14:49:11 2011 New Revision: 13150 Log: Add basic support for compiler 'listeners' or callbacks: infrastructure to help debug the compiler. Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm-class-file.lisp branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm-instructions.lisp branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm-class-file.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sat Jan 15 14:49:11 2011 @@ -1020,7 +1020,6 @@ (defun finalize-code-attribute (code parent class) "Prepares the `code' attribute for serialization, within method `parent'." - (declare (ignore parent)) (let* ((handlers (code-exception-handlers code)) (c (finalize-code (code-code code) @@ -1028,6 +1027,8 @@ (mapcar #'exception-end-pc handlers) (mapcar #'exception-handler-pc handlers)) t))) + (invoke-callbacks :code-finalized class parent + (coerce c 'list) handlers) (unless (code-max-stack code) (setf (code-max-stack code) (analyze-stack c (mapcar #'exception-handler-pc handlers)))) Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm-instructions.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm-instructions.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Sat Jan 15 14:49:11 2011 @@ -721,6 +721,12 @@ (let ((opcode (instruction-opcode instruction))) (setf depth (+ depth instruction-stack)) (setf (instruction-depth instruction) depth) + (unless (<= 0 depth) + (internal-compiler-error "Stack inconsistency detected ~ + in ~A at index ~D: ~ + negative depth ~S." + (compiland-name *current-compiland*) + i depth)) (when (branch-p opcode) (let ((label (car (instruction-args instruction)))) (declare (type symbol label)) Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp Sat Jan 15 14:49:11 2011 @@ -53,6 +53,14 @@ (defvar *closure-variables* nil) (defvar *enable-dformat* nil) +(defvar *callbacks* nil + "A list of functions to be called by the compiler and code generator +in order to generate 'compilation events'.") + +(declaim (inline invoke-callbacks)) +(defun invoke-callbacks (&rest args) + (dolist (cb *callbacks*) + (apply cb args))) #+nil (defun dformat (destination control-string &rest args) From ehuelsmann at common-lisp.net Sat Jan 15 20:51:14 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 15 Jan 2011 15:51:14 -0500 Subject: [armedbear-cvs] r13151 - branches/unsafe-p-removal/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jan 15 15:51:11 2011 New Revision: 13151 Log: No longer rewrite ordinary function calls for stack safety, instead, let the code generator determine if it closes over a block of unsafe code. We need to remember per GO/RETURN-FROM to which block they go in order to determine opstack safety. Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sat Jan 15 15:51:11 2011 @@ -620,7 +620,8 @@ (defknown p1-return-from (t) t) (defun p1-return-from (form) (let* ((name (second form)) - (block (find-block name))) + (block (find-block name)) + non-local-p) (when (null block) (compiler-error "RETURN-FROM ~S: no block named ~S is currently visible." name name)) @@ -634,19 +635,22 @@ (let ((protected (enclosed-by-protected-block-p block))) (dformat t "p1-return-from protected = ~S~%" protected) (if protected - (setf (block-non-local-return-p block) t) + (setf (block-non-local-return-p block) t + non-local-p t) ;; non-local GO's ensure environment restoration ;; find out about this local GO (when (null (block-needs-environment-restoration block)) (setf (block-needs-environment-restoration block) (enclosed-by-environment-setting-block-p block)))))) (t - (setf (block-non-local-return-p block) t))) + (setf (block-non-local-return-p block) t + non-local-p t))) (when (block-non-local-return-p block) (dformat t "non-local return from block ~S~%" (block-name block))) (let ((value-form (p1 (caddr form)))) (push value-form (block-return-value-forms block)) - (list 'RETURN-FROM name value-form)))) + (make-jump-node (list 'RETURN-FROM name value-form) + non-local-p block)))) (defun p1-tagbody (form) (let* ((block (make-tagbody-node)) @@ -695,12 +699,14 @@ (unless tag (error "p1-go: tag not found: ~S" name)) (setf (tag-used tag) t) - (let ((tag-block (tag-block tag))) + (let ((tag-block (tag-block tag)) + non-local-p) (cond ((eq (tag-compiland tag) *current-compiland*) ;; Does the GO leave an enclosing UNWIND-PROTECT or CATCH? (if (enclosed-by-protected-block-p tag-block) (setf (tagbody-non-local-go-p tag-block) t - (tag-used-non-locally tag) t) + (tag-used-non-locally tag) t + non-local-p t) ;; non-local GO's ensure environment restoration ;; find out about this local GO (when (null (tagbody-needs-environment-restoration tag-block)) @@ -708,8 +714,9 @@ (enclosed-by-environment-setting-block-p tag-block))))) (t (setf (tagbody-non-local-go-p tag-block) t - (tag-used-non-locally tag) t))))) - form) + (tag-used-non-locally tag) t + non-local-p t))) + (make-jump-node form non-local-p tag-block tag)))) (defun validate-function-name (name) (unless (or (symbolp name) (setf-function-name-p name)) @@ -1143,6 +1150,123 @@ (1- (length form)))) (list 'TRULY-THE (%cadr form) (p1 (%caddr form)))) +(defvar *pass2-unsafe-p-special-treatment-functions* + '( + + constantp endp evenp floatp integerp listp minusp + numberp oddp plusp rationalp realp + ;; predicates not marked as such? + simple-vector-p + stringp + symbolp + vectorp + zerop + atom + consp + fixnump + packagep + readtablep + characterp + bit-vector-p + SIMPLE-TYPEP + + declare + multiple-value-call + multiple-value-list + multiple-value-prog1 + nth + progn + + EQL EQUAL + + - / * + < < > >= = /= + ASH + AREF + RPLACA RPLACD + %ldb + and + aset + car + cdr + char + char-code + java:jclass + java:jconstructor + java:jmethod + char= + coerce-to-function + cons + sys::backq-cons + delete + elt + eq + eql + find-class + funcall + function + gensym + get + getf + gethash + gethash1 + if + sys::%length + list + sys::backq-list + list* + sys::backq-list* + load-time-value + logand + logior + lognot + logxor + max + memq + memql + min + mod + neq + not + nthcdr + null + or + puthash + quote + read-line + rplacd + schar + set + set-car + set-cdr + set-char + set-schar + set-std-slot-value + setq + std-slot-value + stream-element-type + structure-ref + structure-set + svref + svset + sxhash + symbol-name + symbol-package + symbol-value + truncate + values + vector-push-extend + write-8-bits + with-inline-code) +"The functions named in the list bound to this variable +need to be rewritten if UNSAFE-P returns non-NIL for their +argument list. + +All other function calls are handled by generic function calling +in pass2, which accounts for OPSTACK unsafety itself.") + + + + (defknown unsafe-p (t) t) (defun unsafe-p (args) "Determines whether the args can cause 'stack unsafe situations'. @@ -1188,7 +1312,8 @@ ((and (listp op) (eq (car op) 'lambda)) ;;((lambda (...) ...) ...) (expand-function-call-inline form (cadr op) (copy-tree (cddr op)) args)) - (t (if (unsafe-p args) + (t (if (and (member op *pass2-unsafe-p-special-treatment-functions*) + (unsafe-p args)) (let ((arg1 (car args))) (cond ((and (consp arg1) (eq (car arg1) 'GO)) arg1) @@ -1197,7 +1322,8 @@ (lets ())) ;; Preserve the order of evaluation of the arguments! (dolist (arg args) - (cond ((constantp arg) + (cond ((and (constantp arg) + (not (node-p arg))) (push arg syms)) ((and (consp arg) (eq (car arg) 'GO)) (return-from rewrite-function-call Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Jan 15 15:51:11 2011 @@ -598,6 +598,8 @@ (single-valued-p (second (node-form form)))) ((catch-node-p form) nil) + ((jump-node-p form) + (single-valued-p (node-form form))) (t (assert (not "SINGLE-VALUED-P unhandled NODE-P branch"))))) ((var-ref-p form) @@ -696,7 +698,7 @@ on the operand stack, if it's safe to do so. Otherwise stores the value in a register" (let ((unsafe (or *saved-operands* - (some-nested-block #'block-opstack-unsafe-p + (some-nested-block #'node-opstack-unsafe-p (find-enclosed-blocks form))))) (when (and unsafe (null *saved-operands*)) (save-existing-operands)) @@ -1856,8 +1858,8 @@ (t nil))) -(defknown process-args (t) t) -(defun process-args (args) +(defknown process-args (t t) t) +(defun process-args (args stack) "Compiles forms specified as function call arguments. The results are either accumulated on the stack or in an array @@ -1865,27 +1867,76 @@ itself is *not* compiled by this function." (when args (let ((numargs (length args))) - (let ((must-clear-values nil)) + (let ((must-clear-values nil) + (unsafe-args (some-nested-block #'node-opstack-unsafe-p + (mapcan #'find-enclosed-blocks + args)))) (declare (type boolean must-clear-values)) - (cond ((<= numargs call-registers-limit) + (cond ((and unsafe-args + (<= numargs call-registers-limit)) + (let ((*register* *register*) + operand-registers) + (dolist (stack-item stack) + (let ((register (allocate-register))) + (push register operand-registers) + (emit-move-from-stack register stack-item))) + (setf operand-registers (reverse operand-registers)) + (dolist (arg args) + (push (allocate-register) operand-registers) + (compile-form arg (car operand-registers) nil) + (unless must-clear-values + (unless (single-valued-p arg) + (setf must-clear-values t)))) + (dolist (register (nreverse operand-registers)) + (aload register)))) + ((<= numargs call-registers-limit) (dolist (arg args) (compile-form arg 'stack nil) (unless must-clear-values (unless (single-valued-p arg) (setf must-clear-values t))))) (t - (emit-push-constant-int numargs) - (emit-anewarray +lisp-object+) - (let ((i 0)) - (dolist (arg args) - (emit 'dup) - (emit-push-constant-int i) - (compile-form arg 'stack nil) - (emit 'aastore) ; store value in array - (unless must-clear-values - (unless (single-valued-p arg) - (setf must-clear-values t))) - (incf i))))) + (let (;(*register* *register*) ;; ### FIXME: this doesn't work, but why not? + (array-register (allocate-register)) + saved-stack) + (when unsafe-args + (dolist (stack-item stack) + (let ((register (allocate-register))) + (push register saved-stack) + (emit-move-from-stack register stack-item)))) + (emit-push-constant-int numargs) + (emit-anewarray +lisp-object+) + ;; be operand stack safe by not accumulating + ;; any arguments on the stack. + ;; + ;; The overhead of storing+loading the array register + ;; at the beginning and ending is small: there are at + ;; least nine parameters to be calculated. + (astore array-register) + (let ((i 0)) + (dolist (arg args) + (cond + ((not (some-nested-block #'node-opstack-unsafe-p + (find-enclosed-blocks arg))) + (aload array-register) + (emit-push-constant-int i) + (compile-form arg 'stack nil)) + (t + (compile-form arg 'stack nil) + (aload array-register) + (emit 'swap) + (emit-push-constant-int i) + (emit 'swap))) + (emit 'aastore) ; store value in array + (unless must-clear-values + (unless (single-valued-p arg) + (setf must-clear-values t))) + (incf i)) + (when unsafe-args + (mapcar #'emit-push-register + saved-stack + (reverse stack))) + (aload array-register))))) (when must-clear-values (emit-clear-values))))) t) @@ -1953,26 +2004,28 @@ (aload 0))) (t (emit-load-externalized-object op))) - (process-args args) + (process-args args + (if (or (<= *speed* *debug*) *require-stack-frame*) + '(nil nil) '(nil))) (if (or (<= *speed* *debug*) *require-stack-frame*) (emit-call-thread-execute numargs) (emit-call-execute numargs)) (fix-boxing representation (derive-compiler-type form)) (emit-move-from-stack target representation)))) -(defun compile-call (args) +(defun compile-call (args stack) "Compiles a function call. Depending on the `*speed*' and `*debug*' settings, a stack frame is registered (or not)." (let ((numargs (length args))) (cond ((> *speed* *debug*) - (process-args args) + (process-args args stack) (emit-call-execute numargs)) (t (emit-push-current-thread) (emit 'swap) ; Stack: thread function - (process-args args) + (process-args args (list* (car stack) nil (cdr stack))) (emit-call-thread-execute numargs))))) (define-source-transform funcall (&whole form fun &rest args) @@ -2039,7 +2092,7 @@ (when (> *debug* *speed*) (return-from p2-funcall (compile-function-call form target representation))) (compile-forms-and-maybe-emit-clear-values (cadr form) 'stack nil) - (compile-call (cddr form)) + (compile-call (cddr form) '(nil)) (fix-boxing representation nil) (emit-move-from-stack target)) @@ -2104,7 +2157,7 @@ (emit-invokestatic +lisp+ "makeCompiledClosure" (list +lisp-object+ +closure-binding-array+) +lisp-object+))))) - (process-args args) + (process-args args '(nil)) (emit-call-execute (length args)) (fix-boxing representation nil) (emit-move-from-stack target representation)) @@ -3003,8 +3056,8 @@ ) (defun restore-environment-and-make-handler (register label-START) - (let ((label-END (gensym)) - (label-EXIT (gensym))) + (let ((label-END (gensym "U")) + (label-EXIT (gensym "E"))) (emit 'goto label-EXIT) (label label-END) (restore-dynamic-environment register) @@ -3021,7 +3074,7 @@ (vars (second form)) (bind-special-p nil) (variables (m-v-b-vars block)) - (label-START (gensym))) + (label-START (gensym "F"))) (dolist (variable variables) (let ((special-p (variable-special-p variable))) (cond (special-p @@ -3424,7 +3477,7 @@ (form (let-form block)) (*visible-variables* *visible-variables*) (specialp nil) - (label-START (gensym))) + (label-START (gensym "F"))) ;; Walk the variable list looking for special bindings and unused lexicals. (dolist (variable (let-vars block)) (cond ((variable-special-p variable) @@ -3471,10 +3524,10 @@ (*register* *register*) (form (tagbody-form block)) (body (cdr form)) - (BEGIN-BLOCK (gensym)) - (END-BLOCK (gensym)) - (RETHROW (gensym)) - (EXIT (gensym)) + (BEGIN-BLOCK (gensym "F")) + (END-BLOCK (gensym "U")) + (RETHROW (gensym "T")) + (EXIT (gensym "E")) (must-clear-values nil) (specials-register (when (tagbody-non-local-go-p block) (allocate-register)))) @@ -3511,8 +3564,8 @@ (emit 'goto EXIT) (when (tagbody-non-local-go-p block) ; We need a handler to catch non-local GOs. - (let* ((HANDLER (gensym)) - (EXTENT-EXIT-HANDLER (gensym)) + (let* ((HANDLER (gensym "H")) + (EXTENT-EXIT-HANDLER (gensym "HE")) (*register* *register*) (go-register (allocate-register)) (tag-register (allocate-register))) @@ -3565,9 +3618,11 @@ (defun p2-go (form target representation) ;; FIXME What if we're called with a non-NIL representation? (declare (ignore target representation)) - (let* ((name (cadr form)) - (tag (find-tag name)) - (tag-block (when tag (tag-block tag)))) + (let* ((node form) + (form (node-form form)) + (name (cadr form)) + (tag (jump-target-tag node)) + (tag-block (when tag (jump-target-block node)))) (unless tag (error "p2-go: tag not found: ~S" name)) (when (and (eq (tag-compiland tag) *current-compiland*) @@ -3671,8 +3726,8 @@ (aver (block-node-p block))) (let* ((*blocks* (cons block *blocks*)) (*register* *register*) - (BEGIN-BLOCK (gensym)) - (END-BLOCK (gensym)) + (BEGIN-BLOCK (gensym "F")) + (END-BLOCK (gensym "U")) (BLOCK-EXIT (block-exit block)) (specials-register (when (block-non-local-return-p block) (allocate-register)))) @@ -3695,8 +3750,8 @@ (when (block-non-local-return-p block) ;; We need a handler to catch non-local RETURNs. (emit 'goto BLOCK-EXIT) ; Jump over handler, when inserting one - (let ((HANDLER (gensym)) - (EXTENT-EXIT-HANDLER (gensym)) + (let ((HANDLER (gensym "H")) + (EXTENT-EXIT-HANDLER (gensym "HE")) (THIS-BLOCK (gensym))) (label HANDLER) ;; The Return object is on the runtime stack. Stack depth is 1. @@ -3731,9 +3786,11 @@ (defun p2-return-from (form target representation) ;; FIXME What if we're called with a non-NIL representation? (declare (ignore target representation)) - (let* ((name (second form)) + (let* ((node form) + (form (node-form form)) + (name (second form)) (result-form (third form)) - (block (find-block name))) + (block (jump-target-block node))) (when (null block) (error "No block named ~S is currently visible." name)) (let ((compiland *current-compiland*)) @@ -3823,7 +3880,7 @@ (*register* *register*) (environment-register (setf (progv-environment-register block) (allocate-register))) - (label-START (gensym))) + (label-START (gensym "F"))) (with-operand-accumulation ((compile-operand symbols-form nil) (compile-operand values-form nil)) @@ -6506,9 +6563,9 @@ (let* ((form (synchronized-form block)) (*register* *register*) (object-register (allocate-register)) - (BEGIN-PROTECTED-RANGE (gensym)) - (END-PROTECTED-RANGE (gensym)) - (EXIT (gensym))) + (BEGIN-PROTECTED-RANGE (gensym "F")) + (END-PROTECTED-RANGE (gensym "U")) + (EXIT (gensym "E"))) (compile-form (cadr form) 'stack nil) (emit-invokevirtual +lisp-object+ "lockableInstance" nil +java-object+) ; value to synchronize @@ -6542,12 +6599,12 @@ (return-from p2-catch-node)) (let* ((*register* *register*) (tag-register (allocate-register)) - (BEGIN-PROTECTED-RANGE (gensym)) - (END-PROTECTED-RANGE (gensym)) - (THROW-HANDLER (gensym)) + (BEGIN-PROTECTED-RANGE (gensym "F")) + (END-PROTECTED-RANGE (gensym "U")) + (THROW-HANDLER (gensym "H")) (RETHROW (gensym)) (DEFAULT-HANDLER (gensym)) - (EXIT (gensym)) + (EXIT (gensym "E")) (specials-register (allocate-register))) (compile-form (second form) tag-register nil) ; Tag. (emit-push-current-thread) @@ -6637,10 +6694,10 @@ (result-register (allocate-register)) (values-register (allocate-register)) (specials-register (allocate-register)) - (BEGIN-PROTECTED-RANGE (gensym)) - (END-PROTECTED-RANGE (gensym)) - (HANDLER (gensym)) - (EXIT (gensym))) + (BEGIN-PROTECTED-RANGE (gensym "F")) + (END-PROTECTED-RANGE (gensym "U")) + (HANDLER (gensym "H")) + (EXIT (gensym "E"))) ;; Make sure there are no leftover multiple return values from previous calls. (emit-clear-values) @@ -6729,6 +6786,15 @@ (compile-var-ref form target representation)) ((node-p form) (cond + ((jump-node-p form) + (let ((op (car (node-form form)))) + (cond + ((eq op 'go) + (p2-go form target representation)) + ((eq op 'return-from) + (p2-return-from form target representation)) + (t + (assert (not "jump-node: can't happen")))))) ((block-node-p form) (p2-block-node form target representation)) ((let/let*-node-p form) @@ -6863,7 +6929,7 @@ (*thread* nil) (*initialize-thread-var* nil) - (label-START (gensym))) + (label-START (gensym "F"))) (class-add-method class-file method) Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp Sat Jan 15 15:51:11 2011 @@ -483,6 +483,21 @@ (add-node-child *block* block) block)) +(defstruct (jump-node (:conc-name jump-) + (:include node) + (:constructor + %make-jump-node (non-local-p target-block target-tag))) + non-local-p + target-block + target-tag) +(defun make-jump-node (form non-local-p target-block &optional target-tag) + (let ((node (%make-jump-node non-local-p target-block target-tag))) + ;; Don't push into compiland blocks, as this as a node rather than a block + (setf (node-form node) form) + (add-node-child *block* node) + node)) + + ;; binding blocks: LET, LET*, FLET, LABELS, M-V-B, PROGV, LOCALLY ;; ;; Binding blocks can carry references to local (optionally special) variable bindings, @@ -619,11 +634,14 @@ (when *blocks* ;; when the innermost enclosing block doesn't have node-children, ;; there's really nothing to search for. - (when (null (node-children (car *blocks*))) - (return-from find-enclosed-blocks))) + (let ((first-enclosing-block (car *blocks*))) + (when (and (eq *current-compiland* + (node-compiland first-enclosing-block)) + (null (node-children first-enclosing-block))) + (return-from find-enclosed-blocks)))) (%find-enclosed-blocks form)) - + (defun some-nested-block (predicate blocks) "Applies `predicate` recursively to the `blocks` and its children, @@ -661,10 +679,15 @@ (catch-node-p object) (synchronized-node-p object))) -(defun block-opstack-unsafe-p (block) - (or (when (tagbody-node-p block) (tagbody-non-local-go-p block)) - (when (block-node-p block) (block-non-local-return-p block)) - (catch-node-p block))) +(defun node-opstack-unsafe-p (node) + (or (when (jump-node-p node) + (let ((target-block (jump-target-block node))) + (and (null (jump-non-local-p node)) + (eq (node-compiland target-block) *current-compiland*) + (member target-block *blocks*)))) + (when (tagbody-node-p node) (tagbody-non-local-go-p node)) + (when (block-node-p node) (block-non-local-return-p node)) + (catch-node-p node))) (defknown block-creates-runtime-bindings-p (t) boolean) (defun block-creates-runtime-bindings-p (block) From ehuelsmann at common-lisp.net Sun Jan 16 10:46:00 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 16 Jan 2011 05:46:00 -0500 Subject: [armedbear-cvs] r13152 - branches/unsafe-p-removal/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 16 05:45:55 2011 New Revision: 13152 Log: A jump being local already implies it's within the same compiland. Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp Sun Jan 16 05:45:55 2011 @@ -683,7 +683,6 @@ (or (when (jump-node-p node) (let ((target-block (jump-target-block node))) (and (null (jump-non-local-p node)) - (eq (node-compiland target-block) *current-compiland*) (member target-block *blocks*)))) (when (tagbody-node-p node) (tagbody-non-local-go-p node)) (when (block-node-p node) (block-non-local-return-p node)) From ehuelsmann at common-lisp.net Sun Jan 16 12:02:56 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 16 Jan 2011 07:02:56 -0500 Subject: [armedbear-cvs] r13153 - branches/unsafe-p-removal/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 16 07:02:54 2011 New Revision: 13153 Log: First batch of UNSAFE-P function conversions. Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Jan 16 07:02:54 2011 @@ -1153,41 +1153,9 @@ (defvar *pass2-unsafe-p-special-treatment-functions* '( - constantp endp evenp floatp integerp listp minusp - numberp oddp plusp rationalp realp - ;; predicates not marked as such? - simple-vector-p - stringp - symbolp - vectorp - zerop - atom - consp - fixnump - packagep - readtablep - characterp - bit-vector-p - SIMPLE-TYPEP - - declare - multiple-value-call - multiple-value-list - multiple-value-prog1 - nth - progn - - EQL EQUAL - + - / * - < < > >= = /= - ASH - AREF - RPLACA RPLACD %ldb and aset - car - cdr char char-code java:jclass @@ -1199,8 +1167,6 @@ sys::backq-cons delete elt - eq - eql find-class funcall function @@ -1209,7 +1175,6 @@ getf gethash gethash1 - if sys::%length list sys::backq-list @@ -1225,7 +1190,6 @@ memql min mod - neq not nthcdr null Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Jan 16 07:02:54 2011 @@ -671,7 +671,8 @@ &body funcall-body) `(let (*saved-operands* *operand-representations* - (*register* *register*)) ;; hmm can we do this?? either body + (*register* *register*) + ) ;; hmm can we do this?? either body ;; could allocate registers ... , at argument-buildup-body (load-saved-operands) @@ -680,20 +681,21 @@ (defun load-saved-operands () "Load any operands which have been saved into registers back onto the stack in preparation of the execution of the opcode." - (dolist (operand (reverse *saved-operands*)) - (emit 'aload operand))) + (mapcar #'emit-push-register + (reverse *saved-operands*) + (reverse *operand-representations*))) (defun save-existing-operands () "If any operands have been compiled to the stack, save them in registers." - (dotimes (i (length *operand-representations*)) + (dolist (representation *operand-representations*) (let ((register (allocate-register))) (push register *saved-operands*) - (emit 'astore register))) + (emit-move-from-stack register representation))) (setf *saved-operands* (nreverse *saved-operands*))) -(defun compile-operand (form representation) +(defun compile-operand (form representation &optional cast) "Compiles `form` into `representation`, storing the resulting value on the operand stack, if it's safe to do so. Otherwise stores the value in a register" @@ -704,11 +706,12 @@ (save-existing-operands)) (compile-form form 'stack representation) + (when cast + (emit-checkcast cast)) (when unsafe (let ((register (allocate-register))) (push register *saved-operands*) - (assert (null representation)) - (emit 'astore register))) + (emit-move-from-stack register representation))) (push representation *operand-representations*))) @@ -830,6 +833,19 @@ (sys::%format t "emit-move-from-stack general case~%") (aver nil)))) +(defknown emit-push-register (t &optional t) t) +(defun emit-push-register (source &optional representation) + (declare (optimize speed)) + (assert (fixnump source)) + (emit (ecase representation + ((:int :boolean :char) + 'iload) + (:long 'lload) + (:float 'fload) + (:double 'dload) + ((nil) 'aload)) + source)) + ;; Expects value on stack. (defknown emit-invoke-method (t t t) t) (defun emit-invoke-method (method-name target representation) @@ -1596,10 +1612,12 @@ (defun compile-binary-operation (op args target representation) (let ((arg1 (car args)) (arg2 (cadr args))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) - (emit-invokevirtual +lisp-object+ op - (lisp-object-arg-types 1) +lisp-object+) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2)) + (emit-invokevirtual +lisp-object+ op + (lisp-object-arg-types 1) +lisp-object+)) (fix-boxing representation nil) (emit-move-from-stack target representation))) @@ -1649,16 +1667,18 @@ (args (%cdr form)) (arg1 (%car args)) (arg2 (%cadr args))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) - (let ((LABEL1 (gensym)) - (LABEL2 (gensym))) - (emit (if (eq op 'EQ) 'if_acmpne 'if_acmpeq) LABEL1) - (emit-push-true representation) - (emit 'goto LABEL2) - (label LABEL1) - (emit-push-false representation) - (label LABEL2)) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2)) + (let ((LABEL1 (gensym)) + (LABEL2 (gensym))) + (emit (if (eq op 'EQ) 'if_acmpne 'if_acmpeq) LABEL1) + (emit-push-true representation) + (emit 'goto LABEL2) + (label LABEL1) + (emit-push-false representation) + (label LABEL2))) (emit-move-from-stack target representation)) t) @@ -1676,8 +1696,10 @@ (type2 (derive-compiler-type arg2))) (cond ((and (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (let ((label1 (gensym)) (label2 (gensym))) (emit 'if_icmpeq label1) @@ -1687,26 +1709,36 @@ (emit-push-true representation) (label label2))) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit-ifne-for-eql representation '(:int))) ((fixnum-type-p type1) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit 'swap) (emit-ifne-for-eql representation '(:int))) ((eq type2 'CHARACTER) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :char) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :char) + (maybe-emit-clear-values arg1 arg2))) (emit-ifne-for-eql representation '(:char))) ((eq type1 'CHARACTER) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :char - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 :char) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit 'swap) (emit-ifne-for-eql representation '(:char))) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (ecase representation (:boolean (emit-invokevirtual +lisp-object+ "eql" @@ -2212,15 +2244,16 @@ (common-rep (let ((LABEL1 (gensym)) (LABEL2 (gensym))) - (compile-forms-and-maybe-emit-clear-values - arg1 'stack common-rep - arg2 'stack common-rep) - (emit-numeric-comparison op common-rep LABEL1) - (emit-push-true representation) - (emit 'goto LABEL2) - (label LABEL1) - (emit-push-false representation) - (label LABEL2)) + (with-operand-accumulation + ((compile-operand arg1 common-rep) + (compile-operand arg2 common-rep) + (maybe-emit-clear-values arg1 arg2)) + (emit-numeric-comparison op common-rep LABEL1) + (emit-push-true representation) + (emit 'goto LABEL2) + (label LABEL1) + (emit-push-false representation) + (label LABEL2))) (emit-move-from-stack target representation) (return-from p2-numeric-comparison)) ((fixnump arg2) @@ -2264,17 +2297,17 @@ (allocate-register))) (arg3-register (unless (node-constant-p arg3) (allocate-register)))) - (compile-form arg1 'stack :int) - (compile-form arg2 'stack :int) - (when arg2-register - (emit 'dup) - (emit 'istore arg2-register)) - (cond (arg3-register - (compile-form arg3 'stack :int) - (emit 'istore arg3-register) - (maybe-emit-clear-values arg1 arg2 arg3)) - (t - (maybe-emit-clear-values arg1 arg2))) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 :int) + (when arg3-register + (compile-operand arg3 :int)) + (maybe-emit-clear-values arg1 arg2 arg3)) + (when arg3-register + (emit 'istore arg3-register)) + (when arg2-register + (emit 'dup) + (emit 'istore arg2-register))) ;; First test. (emit test LABEL1) ;; Second test. @@ -2524,16 +2557,20 @@ (when (check-arg-count form 2) (let* ((arg1 (%cadr form)) (arg2 (%caddr form))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :char - arg2 'stack :char) + (with-operand-accumulation + ((compile-operand arg1 :char) + (compile-operand arg2 :char) + (maybe-emit-clear-values arg1 arg2))) 'if_icmpne))) (defun p2-test-eq (form) (when (check-arg-count form 2) (let ((arg1 (%cadr form)) (arg2 (%caddr form))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) 'if_acmpne))) (defun p2-test-and (form) @@ -2562,38 +2599,52 @@ (type1 (derive-compiler-type arg1)) (type2 (derive-compiler-type arg2))) (cond ((and (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) 'if_icmpne) ((and (eq type1 'CHARACTER) (eq type2 'CHARACTER)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :char - arg2 'stack :char) + (with-operand-accumulation + ((compile-operand arg1 :char) + (compile-operand arg2 :char) + (maybe-emit-clear-values arg1 arg2))) 'if_icmpne) ((eq type2 'CHARACTER) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :char) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :char) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean) 'ifeq) ((eq type1 'CHARACTER) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :char - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 :char) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit 'swap) (emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean) 'ifeq) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean) 'ifeq) ((fixnum-type-p type1) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit 'swap) (emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean) 'ifeq) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "eql" (lisp-object-arg-types 1) :boolean) 'ifeq))))) @@ -2607,14 +2658,18 @@ (arg1 (%cadr form)) (arg2 (%caddr form))) (cond ((fixnum-type-p (derive-compiler-type arg2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ translated-op '(:int) :boolean)) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ translated-op (lisp-object-arg-types 1) :boolean))) @@ -2624,8 +2679,10 @@ (when (check-arg-count form 2) (let ((arg1 (%cadr form)) (arg2 (%caddr form))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "typep" (lisp-object-arg-types 1) +lisp-object+) (emit-push-nil) @@ -2635,8 +2692,10 @@ (when (check-arg-count form 2) (let ((arg1 (%cadr form)) (arg2 (%caddr form))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokestatic +lisp+ "memq" (lisp-object-arg-types 2) :boolean) 'ifeq))) @@ -2645,8 +2704,10 @@ (when (check-arg-count form 2) (let ((arg1 (%cadr form)) (arg2 (%caddr form))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokestatic +lisp+ "memql" (lisp-object-arg-types 2) :boolean) 'ifeq))) @@ -2661,25 +2722,33 @@ (if (/= arg1 arg2) :consequent :alternate)) ((and (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) 'if_icmpeq) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean) 'ifeq) ((fixnum-type-p type1) ;; FIXME Compile the args in reverse order and avoid the swap if ;; either arg is a fixnum or a lexical variable. - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit 'swap) (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean) 'ifeq) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "isNotEqualTo" (lisp-object-arg-types 1) :boolean) 'ifeq))))) @@ -2696,8 +2765,10 @@ (cond ((and (fixnump arg1) (fixnump arg2)) (if (funcall op arg1 arg2) :consequent :alternate)) ((and (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (ecase op (< 'if_icmpge) (<= 'if_icmpgt) @@ -2705,8 +2776,10 @@ (>= 'if_icmplt) (= 'if_icmpne))) ((and (java-long-type-p type1) (java-long-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :long - arg2 'stack :long) + (with-operand-accumulation + ((compile-operand arg1 :long) + (compile-operand arg2 :long) + (maybe-emit-clear-values arg1 arg2))) (emit 'lcmp) (ecase op (< 'ifge) @@ -2715,8 +2788,10 @@ (>= 'iflt) (= 'ifne))) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ (ecase op (< "isLessThan") @@ -2729,8 +2804,10 @@ ((fixnum-type-p type1) ;; FIXME We can compile the args in reverse order and avoid ;; the swap if either arg is a fixnum or a lexical variable. - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit 'swap) (emit-invokevirtual +lisp-object+ (ecase op @@ -2742,8 +2819,10 @@ '(:int) :boolean) 'ifeq) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ (ecase op (< "isLessThan") @@ -2774,8 +2853,10 @@ ;; ERROR CHECKING HERE! (let ((arg1 (second arg)) (arg2 (third arg))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit 'if_acmpeq LABEL1))) ((eq (derive-compiler-type arg) 'BOOLEAN) (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) @@ -5421,10 +5502,12 @@ ((check-arg-count form 2)) (let ((index-form (second form)) (list-form (third form))) - (compile-forms-and-maybe-emit-clear-values index-form 'stack :int - list-form 'stack nil) - (emit 'swap) - (emit-invokevirtual +lisp-object+ "NTH" '(:int) +lisp-object+) + (with-operand-accumulation + ((compile-operand index-form :int) + (compile-operand list-form nil) + (maybe-emit-clear-values index-form list-form)) + (emit 'swap) + (emit-invokevirtual +lisp-object+ "NTH" '(:int) +lisp-object+)) (fix-boxing representation nil) ; FIXME use derived result type (emit-move-from-stack target representation))) @@ -5448,16 +5531,17 @@ (dformat t "p2-times case 1a~%") (compile-constant value target representation)) (result-rep - (compile-forms-and-maybe-emit-clear-values - arg1 'stack result-rep - arg2 'stack result-rep) - (emit (case result-rep - (:int 'imul) - (:long 'lmul) - (:float 'fmul) - (:double 'dmul) - (t - (sys::format t "p2-times: unsupported rep case")))) + (with-operand-accumulation + ((compile-operand arg1 result-rep) + (compile-operand arg2 result-rep) + (maybe-emit-clear-values arg1 arg2)) + (emit (case result-rep + (:int 'imul) + (:long 'lmul) + (:float 'fmul) + (:double 'dmul) + (t + (sys::format t "p2-times: unsupported rep case"))))) (convert-representation result-rep representation) (emit-move-from-stack target representation)) ((fixnump arg2) @@ -5554,19 +5638,20 @@ arg2 nil nil) (emit-move-from-stack target representation)) (result-rep - (compile-forms-and-maybe-emit-clear-values - arg1 'stack result-rep - arg2 'stack result-rep) - (emit (case result-rep - (:int 'iadd) - (:long 'ladd) - (:float 'fadd) - (:double 'dadd) - (t - (sys::format - t "p2-plus: Unexpected result-rep ~S for form ~S." - result-rep form) - (assert nil)))) + (with-operand-accumulation + ((compile-operand arg1 result-rep) + (compile-operand arg2 result-rep) + (maybe-emit-clear-values arg1 arg2)) + (emit (case result-rep + (:int 'iadd) + (:long 'ladd) + (:float 'fadd) + (:double 'dadd) + (t + (sys::format + t "p2-plus: Unexpected result-rep ~S for form ~S." + result-rep form) + (assert nil))))) (convert-representation result-rep representation) (emit-move-from-stack target representation)) ((eql arg2 1) @@ -5576,13 +5661,15 @@ (compile-forms-and-maybe-emit-clear-values arg2 'stack nil) (emit-invoke-method "incr" target representation)) ((or (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values - arg1 'stack (when (fixnum-type-p type1) :int) - arg2 'stack (when (null (fixnum-type-p type1)) :int)) - (when (fixnum-type-p type1) - (emit 'swap)) - (emit-invokevirtual +lisp-object+ "add" - '(:int) +lisp-object+) + (with-operand-accumulation + ((compile-operand arg1 (when (fixnum-type-p type1) :int)) + (compile-operand arg2 (when (null (fixnum-type-p type1)) + :int)) + (maybe-emit-clear-values arg1 arg2)) + (when (fixnum-type-p type1) + (emit 'swap)) + (emit-invokevirtual +lisp-object+ "add" + '(:int) +lisp-object+)) (fix-boxing representation result-type) (emit-move-from-stack target representation)) (t @@ -5634,27 +5721,29 @@ (cond ((and (numberp arg1) (numberp arg2)) (compile-constant (- arg1 arg2) target representation)) (result-rep - (compile-forms-and-maybe-emit-clear-values - arg1 'stack result-rep - arg2 'stack result-rep) - (emit (case result-rep - (:int 'isub) - (:long 'lsub) - (:float 'fsub) - (:double 'dsub) - (t - (sys::%format t "p2-minus sub-instruction (rep: ~S); form: ~S~%" - result-rep form) - (assert nil)))) + (with-operand-accumulation + ((compile-operand arg1 result-rep) + (compile-operand arg2 result-rep) + (maybe-emit-clear-values arg1 arg2)) + (emit (case result-rep + (:int 'isub) + (:long 'lsub) + (:float 'fsub) + (:double 'dsub) + (t + (sys::%format t "p2-minus sub-instruction (rep: ~S); form: ~S~%" + result-rep form) + (assert nil))))) (convert-representation result-rep representation) (emit-move-from-stack target representation)) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values - arg1 'stack nil - arg2 'stack :int) - (emit-invokevirtual +lisp-object+ - "subtract" - '(:int) +lisp-object+) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2)) + (emit-invokevirtual +lisp-object+ + "subtract" + '(:int) +lisp-object+)) (fix-boxing representation result-type) (emit-move-from-stack target representation)) (t @@ -5819,35 +5908,30 @@ (let* ((arg1 (%cadr form)) (arg2 (%caddr form)) (type1 (derive-compiler-type arg1))) - (ecase representation - (:int - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) - (emit-invokevirtual +lisp-object+ "aref" '(:int) :int)) - (:long - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) - (emit-invokevirtual +lisp-object+ "aref_long" '(:int) :long)) - (:char - (cond ((compiler-subtypep type1 'string) - (compile-form arg1 'stack nil) ; array - (emit-checkcast +lisp-abstract-string+) - (compile-form arg2 'stack :int) ; index - (maybe-emit-clear-values arg1 arg2) - (emit-invokevirtual +lisp-abstract-string+ - "charAt" '(:int) :char)) - (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) - (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+) - (emit-unbox-character)))) - ((nil :float :double :boolean) - ;;###FIXME for float and double, we probably want - ;; separate java methods to retrieve the values. - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) - (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+) - (convert-representation nil representation))) + (with-operand-accumulation + ((compile-operand arg1 nil + (when (compiler-subtypep type1 'string) + +lisp-abstract-string+)) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2)) + (ecase representation + (:int + (emit-invokevirtual +lisp-object+ "aref" '(:int) :int)) + (:long + (emit-invokevirtual +lisp-object+ "aref_long" '(:int) :long)) + (:char + (cond ((compiler-subtypep type1 'string) + (emit-invokevirtual +lisp-abstract-string+ + "charAt" '(:int) :char)) + (t + (emit-invokevirtual +lisp-object+ + "AREF" '(:int) +lisp-object+) + (emit-unbox-character)))) + ((nil :float :double :boolean) + ;;###FIXME for float and double, we probably want + ;; separate java methods to retrieve the values. + (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+) + (convert-representation nil representation)))) (emit-move-from-stack target representation))) (t (compile-function-call form target representation)))) From ehuelsmann at common-lisp.net Mon Jan 17 21:19:38 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 17 Jan 2011 16:19:38 -0500 Subject: [armedbear-cvs] r13154 - branches/unsafe-p-removal/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jan 17 16:19:33 2011 New Revision: 13154 Log: Provide better infrastructure for operand accumulation. Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Mon Jan 17 16:19:33 2011 @@ -667,17 +667,40 @@ (declaim (special *saved-operands* *operand-representations*)) -(defmacro with-operand-accumulation ((&body argument-buildup-body) - &body funcall-body) +(defmacro with-operand-accumulation ((&body argument-accumulation-body) + &body call-body) + "Macro used to operand-stack-safely collect arguments in the +`argument-accumulation-body' to be available on the stack upon entry of the +`call-body'. The argument-accumulation-body code may not assume arguments +are actually on the stack while accumulating. + +This macro closes over a code-generating block. Operands can be collected +using the `accumulate-operand', `compile-operand', `emit-variable-operand' +and `emit-load-externalized-object-operand'." `(let (*saved-operands* - *operand-representations* - (*register* *register*) + *operand-representations* + (*register* *register*) ) ;; hmm can we do this?? either body ;; could allocate registers ... - , at argument-buildup-body + , at argument-accumulation-body (load-saved-operands) , at funcall-body)) +(defmacro accumulate-operand ((representation &key unsafe-p) + &body body) + "Macro used to collect a single operand. + +This macro closes over a code-generating block. The generated code should +leave a single operand on the stack, with representation `representation'. +The value `unsafe-p', when provided, is an expression evaluated at run time +to indicate if the body is opstack unsafe." + `(progn + ,@(when unsafe-p + `((when ,unsafe-p + (save-existing-operands)))) + , at body + (save-operand ,representation))) + (defun load-saved-operands () "Load any operands which have been saved into registers back onto the stack in preparation of the execution of the opcode." @@ -688,31 +711,42 @@ (defun save-existing-operands () "If any operands have been compiled to the stack, save them in registers." - (dolist (representation *operand-representations*) + (when (null *saved-operands*) + (dolist (representation *operand-representations*) + (let ((register (allocate-register))) + (push register *saved-operands*) + (emit-move-from-stack register representation))) + + (setf *saved-operands* (nreverse *saved-operands*)))) + +(defun save-operand (representation) + "Saves an operand from the stack (with `representation') to +a register and updates associated operand collection variables." + (push representation *operand-representations*) + + (when *saved-operands* (let ((register (allocate-register))) (push register *saved-operands*) - (emit-move-from-stack register representation))) - - (setf *saved-operands* (nreverse *saved-operands*))) + (emit-move-from-stack register representation)))) (defun compile-operand (form representation &optional cast) - "Compiles `form` into `representation`, storing the resulting value + "Compiles `form' into `representation', storing the resulting value on the operand stack, if it's safe to do so. Otherwise stores the value in a register" (let ((unsafe (or *saved-operands* - (some-nested-block #'node-opstack-unsafe-p - (find-enclosed-blocks form))))) + (some-nested-block #'node-opstack-unsafe-p + (find-enclosed-blocks form))))) (when (and unsafe (null *saved-operands*)) (save-existing-operands)) - + (compile-form form 'stack representation) (when cast (emit-checkcast cast)) (when unsafe (let ((register (allocate-register))) - (push register *saved-operands*) - (emit-move-from-stack register representation))) - + (push register *saved-operands*) + (emit-move-from-stack register representation))) + (push representation *operand-representations*))) (defun emit-variable-operand (variable) @@ -721,7 +755,7 @@ (push (variable-representation variable) *operand-representations*) (cond ((and *saved-operands* - (variable-register variable)) + (variable-register variable)) ;; we're in 'safe mode' and the variable is in a register, ;; instead of binding a new register, just load the existing one (push (variable-register variable) *saved-operands*)) @@ -729,26 +763,24 @@ (emit-push-variable variable) (when *saved-operands* ;; safe-mode (let ((register (allocate-register))) - (push register *saved-operands*) - (assert (null (variable-representation variable))) - (emit 'astore register)))))) + (push register *saved-operands*) + (emit-move-from-stack register (variable-representation variable))))))) (defun emit-thread-operand () (push nil *operand-representations*) (emit-push-current-thread) (when *saved-operands* (let ((register (allocate-register))) - (push register *saved-operands*) - (emit 'astore register)))) - + (push register *saved-operands*) + (emit 'astore register)))) (defun emit-load-externalized-object-operand (object) (push nil *operand-representations*) (emit-load-externalized-object object) (when *saved-operands* ;; safe-mode (let ((register (allocate-register))) - (push register *saved-operands*) - (emit 'astore register)))) + (push register *saved-operands*) + (emit 'astore register)))) (defknown emit-unbox-fixnum () t) (defun emit-unbox-fixnum () @@ -1928,7 +1960,7 @@ (unless (single-valued-p arg) (setf must-clear-values t))))) (t - (let (;(*register* *register*) ;; ### FIXME: this doesn't work, but why not? + (let* ((*register* *register*) ;; ### FIXME: this doesn't work, but why not? (array-register (allocate-register)) saved-stack) (when unsafe-args From ehuelsmann at common-lisp.net Mon Jan 17 22:07:32 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 17 Jan 2011 17:07:32 -0500 Subject: [armedbear-cvs] r13155 - branches/unsafe-p-removal/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jan 17 17:07:31 2011 New Revision: 13155 Log: Allocate registers based on the representation requested, don't use two different functions to allocate. Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Mon Jan 17 17:07:31 2011 @@ -345,12 +345,6 @@ (compiler-subtypep the-type (make-compiler-type type))) (return-from type-representation (caar types)))))) -(defun representation-size (representation) - (ecase representation - ((NIL :int :boolean :float :char) 1) - ((:long :double) 2))) - - (defknown emit-unbox-boolean () t) (defun emit-unbox-boolean () (emit-instanceof +lisp-nil+) @@ -684,7 +678,7 @@ ;; could allocate registers ... , at argument-accumulation-body (load-saved-operands) - , at funcall-body)) + , at call-body)) (defmacro accumulate-operand ((representation &key unsafe-p) &body body) @@ -713,7 +707,7 @@ save them in registers." (when (null *saved-operands*) (dolist (representation *operand-representations*) - (let ((register (allocate-register))) + (let ((register (allocate-register representation))) (push register *saved-operands*) (emit-move-from-stack register representation))) @@ -725,7 +719,7 @@ (push representation *operand-representations*) (when *saved-operands* - (let ((register (allocate-register))) + (let ((register (allocate-register representation))) (push register *saved-operands*) (emit-move-from-stack register representation)))) @@ -743,7 +737,7 @@ (when cast (emit-checkcast cast)) (when unsafe - (let ((register (allocate-register))) + (let ((register (allocate-register representation))) (push register *saved-operands*) (emit-move-from-stack register representation))) @@ -762,7 +756,7 @@ (t (emit-push-variable variable) (when *saved-operands* ;; safe-mode - (let ((register (allocate-register))) + (let ((register (allocate-register (variable-representation variable)))) (push register *saved-operands*) (emit-move-from-stack register (variable-representation variable))))))) @@ -770,7 +764,7 @@ (push nil *operand-representations*) (emit-push-current-thread) (when *saved-operands* - (let ((register (allocate-register))) + (let ((register (allocate-register nil))) (push register *saved-operands*) (emit 'astore register)))) @@ -778,7 +772,7 @@ (push nil *operand-representations*) (emit-load-externalized-object object) (when *saved-operands* ;; safe-mode - (let ((register (allocate-register))) + (let ((register (allocate-register nil))) (push register *saved-operands*) (emit 'astore register)))) @@ -958,7 +952,7 @@ keys-p more-keys-p) (with-code-to-method (class method) - (allocate-register) + (allocate-register nil) (unless (eq super +lisp-compiled-primitive+) (multiple-value-bind (req opt key key-p rest @@ -974,7 +968,7 @@ (emit-push-constant-int (length ,params)) (emit-anewarray +lisp-closure-parameter+) (astore (setf ,register *registers-allocated*)) - (allocate-register) + (allocate-register nil) (do* ((,count-sym 0 (1+ ,count-sym)) (,params ,params (cdr ,params)) (,param (car ,params) (car ,params))) @@ -1941,12 +1935,12 @@ (let ((*register* *register*) operand-registers) (dolist (stack-item stack) - (let ((register (allocate-register))) + (let ((register (allocate-register nil))) (push register operand-registers) (emit-move-from-stack register stack-item))) (setf operand-registers (reverse operand-registers)) (dolist (arg args) - (push (allocate-register) operand-registers) + (push (allocate-register nil) operand-registers) (compile-form arg (car operand-registers) nil) (unless must-clear-values (unless (single-valued-p arg) @@ -1961,11 +1955,11 @@ (setf must-clear-values t))))) (t (let* ((*register* *register*) ;; ### FIXME: this doesn't work, but why not? - (array-register (allocate-register)) + (array-register (allocate-register nil)) saved-stack) (when unsafe-args (dolist (stack-item stack) - (let ((register (allocate-register))) + (let ((register (allocate-register nil))) (push register saved-stack) (emit-move-from-stack register stack-item)))) (emit-push-constant-int numargs) @@ -2163,7 +2157,7 @@ (defun duplicate-closure-array (compiland) (let* ((*register* *register*) - (register (allocate-register))) + (register (allocate-register nil))) (aload (compiland-closure-register compiland)) ;; src (emit-push-constant-int 0) ;; srcPos (emit-push-constant-int (length *closure-variables*)) @@ -2326,9 +2320,9 @@ (unless (and (or (node-constant-p arg2) (var-ref-p arg2)) (node-constant-p arg3)) - (allocate-register))) + (allocate-register nil))) (arg3-register - (unless (node-constant-p arg3) (allocate-register)))) + (unless (node-constant-p arg3) (allocate-register nil)))) (with-operand-accumulation ((compile-operand arg1 :int) (compile-operand arg2 :int) @@ -3007,8 +3001,8 @@ (defun compile-multiple-value-prog1 (form target representation) (let ((first-subform (cadr form)) (subforms (cddr form)) - (result-register (allocate-register)) - (values-register (allocate-register))) + (result-register (allocate-register nil)) + (values-register (allocate-register nil))) ;; Make sure there are no leftover values from previous calls. (emit-clear-values) (compile-form first-subform result-register nil) @@ -3039,7 +3033,7 @@ (emit-invokevirtual +lisp-object+ "execute" nil +lisp-object+)) (3 (let* ((*register* *register*) - (function-register (allocate-register))) + (function-register (allocate-register nil))) (compile-form (second form) function-register nil) (compile-form (third form) 'stack nil) (aload function-register) @@ -3050,8 +3044,8 @@ (t ;; The general case. (let* ((*register* *register*) - (function-register (allocate-register)) - (values-register (allocate-register))) + (function-register (allocate-register nil)) + (values-register (allocate-register nil))) (compile-form (second form) 'stack nil) (emit-invokestatic +lisp+ "coerceToFunction" (lisp-object-arg-types 1) +lisp-object+) @@ -3194,12 +3188,13 @@ (setf bind-special-p t)) (t (unless (variable-closure-index variable) - (setf (variable-register variable) (allocate-register))))))) + (setf (variable-register variable) + (allocate-register nil))))))) ;; If we're going to bind any special variables... (when bind-special-p (dformat t "p2-m-v-b-node lastSpecialBinding~%") ;; Save current dynamic environment. - (setf (m-v-b-environment-register block) (allocate-register)) + (setf (m-v-b-environment-register block) (allocate-register nil)) (save-dynamic-environment (m-v-b-environment-register block)) (label label-START)) ;; Make sure there are no leftover values from previous calls. @@ -3211,8 +3206,8 @@ (compile-binding (car variables))) (t (let* ((*register* *register*) - (result-register (allocate-register)) - (values-register (allocate-register)) + (result-register (allocate-register nil)) + (values-register (allocate-register nil)) (LABEL1 (gensym)) (LABEL2 (gensym))) ;; Store primary value from values form in result register. @@ -3367,9 +3362,7 @@ (defun allocate-variable-register (variable) (setf (variable-register variable) - (if (= 2 (representation-size (variable-representation variable))) - (allocate-register-pair) - (allocate-register)))) + (allocate-register (variable-representation variable)))) (defun emit-move-to-variable (variable) (let ((representation (variable-representation variable))) @@ -3479,9 +3472,9 @@ (allocate-variable-register variable)) (when (variable-special-p variable) (setf (variable-binding-register variable) - (allocate-register))) + (allocate-register nil))) (cond ((variable-special-p variable) - (let ((temp-register (allocate-register))) + (let ((temp-register (allocate-register nil))) ;; FIXME: this permanently allocates a register ;; which has only a single local use (push (cons temp-register variable) @@ -3543,7 +3536,8 @@ (not (variable-special-p variable)) (eq (variable-declared-type variable) 'BOOLEAN)) (setf (variable-representation variable) :boolean) - (setf (variable-register variable) (allocate-register)) + (setf (variable-register variable) + (allocate-register nil)) (emit 'iconst_0) (emit 'istore (variable-register variable)) (setf boundp t)) @@ -3573,11 +3567,13 @@ (unless (or boundp (variable-special-p variable)) (unless (or (variable-closure-index variable) (variable-register variable)) - (setf (variable-register variable) (allocate-register)))) + (setf (variable-register variable) + (allocate-register nil)))) (push variable *visible-variables*) (unless boundp (when (variable-special-p variable) - (setf (variable-binding-register variable) (allocate-register))) + (setf (variable-binding-register variable) + (allocate-register nil))) (compile-binding variable)) (maybe-generate-type-check variable))) (when must-clear-values @@ -3600,7 +3596,7 @@ ;; If there are any special bindings... (when specialp ;; We need to save current dynamic environment. - (setf (let-environment-register block) (allocate-register)) + (setf (let-environment-register block) (allocate-register nil)) (save-dynamic-environment (let-environment-register block)) (label label-START)) (propagate-vars block) @@ -3643,7 +3639,7 @@ (EXIT (gensym "E")) (must-clear-values nil) (specials-register (when (tagbody-non-local-go-p block) - (allocate-register)))) + (allocate-register nil)))) ;; Scan for tags. (dolist (tag (tagbody-tags block)) (push tag *visible-tags*)) @@ -3680,8 +3676,8 @@ (let* ((HANDLER (gensym "H")) (EXTENT-EXIT-HANDLER (gensym "HE")) (*register* *register*) - (go-register (allocate-register)) - (tag-register (allocate-register))) + (go-register (allocate-register nil)) + (tag-register (allocate-register nil))) (label HANDLER) ;; The Go object is on the runtime stack. Stack depth is 1. (emit 'dup) @@ -3843,7 +3839,7 @@ (END-BLOCK (gensym "U")) (BLOCK-EXIT (block-exit block)) (specials-register (when (block-non-local-return-p block) - (allocate-register)))) + (allocate-register nil)))) (setf (block-target block) target) (when (block-id-variable block) ;; we have a block variable; that should be a closure variable @@ -3992,7 +3988,7 @@ (values-form (caddr form)) (*register* *register*) (environment-register - (setf (progv-environment-register block) (allocate-register))) + (setf (progv-environment-register block) (allocate-register nil))) (label-START (gensym "F"))) (with-operand-accumulation ((compile-operand symbols-form nil) @@ -4170,7 +4166,7 @@ (let ((variable (local-function-variable local-function))) (aver (null (variable-register variable))) (unless (variable-closure-index variable) - (setf (variable-register variable) (allocate-register))))) + (setf (variable-register variable) (allocate-register nil))))) (dolist (local-function local-functions) (p2-labels-process-compiland local-function)) (dolist (special (labels-free-specials block)) @@ -4828,7 +4824,7 @@ (arg2 (second args)) (arg3 (third args)) (*register* *register*) - (value-register (when target (allocate-register)))) + (value-register (when target (allocate-register nil)))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil arg3 'stack nil) @@ -5844,7 +5840,7 @@ (fixnum-type-p type2) (compiler-subtypep type3 'CHARACTER)) (let* ((*register* *register*) - (value-register (when target (allocate-register))) + (value-register (when target (allocate-register nil))) (class (if (eq op 'SCHAR) +lisp-simple-string+ +lisp-abstract-string+))) @@ -5884,7 +5880,7 @@ (arg2 (%caddr form)) (arg3 (fourth form)) (*register* *register*) - (value-register (when target (allocate-register)))) + (value-register (when target (allocate-register nil)))) (compile-form arg1 'stack nil) ;; vector (compile-form arg2 'stack :int) ;; index (compile-form arg3 'stack nil) ;; new value @@ -5977,7 +5973,7 @@ (arg3 (third args)) (type3 (derive-compiler-type arg3)) (*register* *register*) - (value-register (unless (null target) (allocate-register)))) + (value-register (unless (null target) (allocate-register nil)))) ;; array (compile-form arg1 'stack nil) ;; index @@ -6065,7 +6061,7 @@ (cond ((and (fixnump arg2) (<= 0 arg2 3)) (let* ((*register* *register*) - (value-register (when target (allocate-register)))) + (value-register (when target (allocate-register nil)))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg3 'stack nil) (when value-register @@ -6080,7 +6076,7 @@ (emit-move-from-stack target representation)))) ((fixnump arg2) (let* ((*register* *register*) - (value-register (when target (allocate-register)))) + (value-register (when target (allocate-register nil)))) (compile-form arg1 'stack nil) (emit-push-constant-int arg2) (compile-form arg3 'stack nil) @@ -6678,7 +6674,7 @@ (defun p2-threads-synchronized-on (block target) (let* ((form (synchronized-form block)) (*register* *register*) - (object-register (allocate-register)) + (object-register (allocate-register nil)) (BEGIN-PROTECTED-RANGE (gensym "F")) (END-PROTECTED-RANGE (gensym "U")) (EXIT (gensym "E"))) @@ -6714,14 +6710,14 @@ (emit-move-from-stack target)) (return-from p2-catch-node)) (let* ((*register* *register*) - (tag-register (allocate-register)) + (tag-register (allocate-register nil)) (BEGIN-PROTECTED-RANGE (gensym "F")) (END-PROTECTED-RANGE (gensym "U")) (THROW-HANDLER (gensym "H")) (RETHROW (gensym)) (DEFAULT-HANDLER (gensym)) (EXIT (gensym "E")) - (specials-register (allocate-register))) + (specials-register (allocate-register nil))) (compile-form (second form) tag-register nil) ; Tag. (emit-push-current-thread) (aload tag-register) @@ -6806,10 +6802,10 @@ (unwinding-form (caddr form)) (cleanup-forms (cdddr form)) (*register* *register*) - (exception-register (allocate-register)) - (result-register (allocate-register)) - (values-register (allocate-register)) - (specials-register (allocate-register)) + (exception-register (allocate-register nil)) + (result-register (allocate-register nil)) + (values-register (allocate-register nil)) + (specials-register (allocate-register nil)) (BEGIN-PROTECTED-RANGE (gensym "F")) (END-PROTECTED-RANGE (gensym "U")) (HANDLER (gensym "H")) @@ -7079,7 +7075,7 @@ (push var *visible-variables*)) (when *using-arg-array* - (setf (compiland-argument-register compiland) (allocate-register))) + (setf (compiland-argument-register compiland) (allocate-register nil))) ;; Assign indices or registers, depending on where the args are ;; located: the arg-array or the call-stack @@ -7089,14 +7085,14 @@ (aver (null (variable-index variable))) (if *using-arg-array* (setf (variable-index variable) index) - (setf (variable-register variable) (allocate-register))) + (setf (variable-register variable) (allocate-register nil))) (incf index))) ;; Reserve the next available slot for the thread register. - (setf *thread* (allocate-register)) + (setf *thread* (allocate-register nil)) (when *closure-variables* - (setf (compiland-closure-register compiland) (allocate-register)) + (setf (compiland-closure-register compiland) (allocate-register nil)) (dformat t "p2-compiland 2 closure register = ~S~%" (compiland-closure-register compiland))) @@ -7167,7 +7163,7 @@ (null (variable-index variable)) ;; not in the array anymore (< (+ (variable-reads variable) (variable-writes variable)) 2)) - (let ((register (allocate-register))) + (let ((register (allocate-register nil))) (aload (compiland-argument-register compiland)) (emit-push-constant-int (variable-index variable)) (emit 'aaload) @@ -7186,12 +7182,12 @@ (when (some #'variable-special-p (compiland-arg-vars compiland)) ;; Save the dynamic environment (setf (compiland-environment-register compiland) - (allocate-register)) + (allocate-register nil)) (save-dynamic-environment (compiland-environment-register compiland)) (label label-START) (dolist (variable (compiland-arg-vars compiland)) (when (variable-special-p variable) - (setf (variable-binding-register variable) (allocate-register)) + (setf (variable-binding-register variable) (allocate-register nil)) (emit-push-current-thread) (emit-push-variable-name variable) (cond ((variable-register variable) Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp Mon Jan 17 17:07:31 2011 @@ -345,25 +345,20 @@ (when (eq name (variable-name variable)) (return variable)))) -(defknown allocate-register () (integer 0 65535)) -(defun allocate-register () - (let* ((register *register*) - (next-register (1+ register))) - (declare (type (unsigned-byte 16) register next-register)) - (setf *register* next-register) - (when (< *registers-allocated* next-register) - (setf *registers-allocated* next-register)) +(defknown representation-size (t) (integer 0 65535)) +(defun representation-size (representation) + (ecase representation + ((NIL :int :boolean :float :char) 1) + ((:long :double) 2))) + +(defknown allocate-register (t) (integer 0 65535)) +(defun allocate-register (representation) + (let ((register *register*)) + (incf *register* (representation-size representation)) + (setf *registers-allocated* + (max *registers-allocated* *register*)) register)) -(defknown allocate-register-pair () (integer 0 65535)) -(defun allocate-register-pair () - (let* ((register *register*) - (next-register (+ register 2))) - (declare (type (unsigned-byte 16) register next-register)) - (setf *register* next-register) - (when (< *registers-allocated* next-register) - (setf *registers-allocated* next-register)) - register)) (defstruct local-function name From ehuelsmann at common-lisp.net Tue Jan 18 16:33:30 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 18 Jan 2011 11:33:30 -0500 Subject: [armedbear-cvs] r13156 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Jan 18 11:33:29 2011 New Revision: 13156 Log: Make 'getStatus()' public. Modified: trunk/abcl/src/org/armedbear/lisp/ProcessingTerminated.java Modified: trunk/abcl/src/org/armedbear/lisp/ProcessingTerminated.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ProcessingTerminated.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ProcessingTerminated.java Tue Jan 18 11:33:29 2011 @@ -52,7 +52,7 @@ this.status = status; } - int getStatus() { + public int getStatus() { return status; } } From ehuelsmann at common-lisp.net Wed Jan 19 13:09:25 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 19 Jan 2011 08:09:25 -0500 Subject: [armedbear-cvs] r13157 - branches/unsafe-p-removal/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Jan 19 08:09:14 2011 New Revision: 13157 Log: Further transition to unsafety detection in pass2. Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Wed Jan 19 08:09:14 2011 @@ -1153,9 +1153,6 @@ (defvar *pass2-unsafe-p-special-treatment-functions* '( - %ldb - and - aset char char-code java:jclass @@ -1191,7 +1188,6 @@ min mod not - nthcdr null or puthash @@ -1220,7 +1216,7 @@ values vector-push-extend write-8-bits - with-inline-code) +) "The functions named in the list bound to this variable need to be rewritten if UNSAFE-P returns non-NIL for their argument list. Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed Jan 19 08:09:14 2011 @@ -4662,9 +4662,11 @@ (emit-move-from-stack target representation)))) ((and (fixnum-type-p size-type) (fixnum-type-p position-type)) - (compile-forms-and-maybe-emit-clear-values size-arg 'stack :int - position-arg 'stack :int - arg3 'stack nil) + (with-operand-accumulation + ((compile-operand size-arg :int) + (compile-operand position-arg :int) + (compile-operand arg3 nil) + (maybe-emit-clear-values size-arg position-arg arg3))) (emit 'dup_x2) ;; use not supported by emit-dup: 3 values involved (emit 'pop) (emit-invokevirtual +lisp-object+ "LDB" '(:int :int) +lisp-object+) @@ -5974,26 +5976,34 @@ (type3 (derive-compiler-type arg3)) (*register* *register*) (value-register (unless (null target) (allocate-register nil)))) + (with-operand-accumulation + ( ;; array - (compile-form arg1 'stack nil) + (compile-operand arg1 nil) ;; index - (compile-form arg2 'stack :int) + (compile-operand arg2 :int) ;; value - (cond ((fixnum-type-p type3) - (compile-form arg3 'stack :int) - (when value-register - (emit 'dup) - (emit-move-from-stack value-register :int))) - (t - (compile-form arg3 'stack nil) - (when value-register - (emit 'dup) - (emit-move-from-stack value-register nil)))) + (accumulate-operand + ((when (fixnum-type-p type3) :int) + :unsafe-p (some-nested-block + #'node-opstack-unsafe-p + (find-enclosed-blocks arg3))) + (cond ((fixnum-type-p type3) + (compile-form arg3 'stack :int) + (when value-register + (emit 'dup) + (emit-move-from-stack value-register :int))) + (t + (compile-form arg3 'stack nil) + (when value-register + (emit 'dup) + (emit-move-from-stack value-register nil))))))) (maybe-emit-clear-values arg1 arg2 arg3) (cond ((fixnum-type-p type3) (emit-invokevirtual +lisp-object+ "aset" '(:int :int) nil)) (t - (emit-invokevirtual +lisp-object+ "aset" (list :int +lisp-object+) nil))) + (emit-invokevirtual +lisp-object+ "aset" + (list :int +lisp-object+) nil))) (when value-register (cond ((fixnum-type-p type3) (emit 'iload value-register) @@ -6147,8 +6157,10 @@ (arg1 (%car args)) (arg2 (%cadr args))) (cond ((fixnum-type-p (derive-compiler-type arg1)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit 'swap) (emit-invokevirtual +lisp-object+ "nthcdr" '(:int) +lisp-object+) (fix-boxing representation nil) From ehuelsmann at common-lisp.net Wed Jan 19 21:07:57 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 19 Jan 2011 16:07:57 -0500 Subject: [armedbear-cvs] r13158 - branches/unsafe-p-removal/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Jan 19 16:07:53 2011 New Revision: 13158 Log: Further transition to unsafety detection in pass2. Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Wed Jan 19 16:07:53 2011 @@ -1153,7 +1153,6 @@ (defvar *pass2-unsafe-p-special-treatment-functions* '( - char char-code java:jclass java:jconstructor @@ -1191,23 +1190,8 @@ null or puthash - quote read-line - rplacd - schar - set - set-car - set-cdr - set-char - set-schar - set-std-slot-value - setq - std-slot-value stream-element-type - structure-ref - structure-set - svref - svset sxhash symbol-name symbol-package Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed Jan 19 16:07:53 2011 @@ -4030,32 +4030,52 @@ (define-inlined-function p2-rplacd (form target representation) ((check-arg-count form 2)) - (let ((args (cdr form))) - (compile-form (first args) 'stack nil) - (when target - (emit 'dup)) - (compile-form (second args) 'stack nil) + (let* ((args (cdr form)) + (*register* *register*) + (target-register (allocate-register nil))) + (with-operand-accumulation + ((accumulate-operand (nil + :unsafe-p (some-nested-block + #'node-opstack-unsafe-p + (find-enclosed-blocks (first args)))) + (compile-form (first args) 'stack nil) + (when target-register + (emit 'dup) + (astore target-register))) + (compile-operand (second args) nil))) + (maybe-emit-clear-values (car args) (cadr args)) (emit-invokevirtual +lisp-object+ "setCdr" (lisp-object-arg-types 1) nil) - (when target + (when target-register + (aload target-register) (fix-boxing representation nil) (emit-move-from-stack target representation)))) (define-inlined-function p2-set-car/cdr (form target representation) ((check-arg-count form 2)) - (let ((op (%car form)) - (args (%cdr form))) - (compile-form (%car args) 'stack nil) - (compile-form (%cadr args) 'stack nil) - (when target - (emit-dup nil :past nil)) + (let* ((op (%car form)) + (args (%cdr form)) + (*register* *register*) + (target-register (when target (allocate-register nil)))) + (with-operand-accumulation + ((compile-operand (%car args) nil) + (accumulate-operand (nil + :unsafe-p (some-nested-block + #'node-opstack-unsafe-p + (find-enclosed-blocks (cadr args)))) + (compile-form (%cadr args) 'stack nil) + (when target-register + (emit 'dup) + (astore target-register))) + (maybe-emit-clear-values (car args) (cadr args)))) (emit-invokevirtual +lisp-object+ (if (eq op 'sys:set-car) "setCar" "setCdr") (lisp-object-arg-types 1) nil) - (when target + (when target-register + (aload target-register) (fix-boxing representation nil) (emit-move-from-stack target representation)))) @@ -4810,8 +4830,10 @@ (let* ((args (cdr form)) (arg1 (first args)) (arg2 (second args))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil))) + (maybe-emit-clear-values arg1 arg2) (emit-invokevirtual +lisp-object+ "SLOT_VALUE" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) @@ -4827,12 +4849,14 @@ (arg3 (third args)) (*register* *register*) (value-register (when target (allocate-register nil)))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil - arg3 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (compile-operand arg3 nil))) (when value-register (emit 'dup) (astore value-register)) + (maybe-emit-clear-values arg1 arg2 arg3) (emit-invokevirtual +lisp-object+ "setSlotValue" (lisp-object-arg-types 2) nil) (when value-register @@ -5792,29 +5816,24 @@ (arg2 (%cadr args)) (type1 (derive-compiler-type arg1)) (type2 (derive-compiler-type arg2))) - (cond ((and (eq representation :char) - (zerop *safety*)) - (compile-form arg1 'stack nil) - (emit-checkcast +lisp-abstract-string+) - (compile-form arg2 'stack :int) - (maybe-emit-clear-values arg1 arg2) - (emit-invokevirtual +lisp-abstract-string+ "charAt" - '(:int) :char) - (emit-move-from-stack target representation)) - ((and (eq representation :char) + (cond ((or (and (eq representation :char) + (zerop *safety*)) + (and (eq representation :char) (or (eq op 'CHAR) (< *safety* 3)) (compiler-subtypep type1 'STRING) - (fixnum-type-p type2)) - (compile-form arg1 'stack nil) - (emit-checkcast +lisp-abstract-string+) - (compile-form arg2 'stack :int) + (fixnum-type-p type2))) + (with-operand-accumulation + ((compile-operand arg1 nil +lisp-abstract-string+) + (compile-operand arg2 :int))) (maybe-emit-clear-values arg1 arg2) (emit-invokevirtual +lisp-abstract-string+ "charAt" '(:int) :char) (emit-move-from-stack target representation)) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ (symbol-name op) ;; "CHAR" or "SCHAR" '(:int) +lisp-object+) @@ -5846,13 +5865,17 @@ (class (if (eq op 'SCHAR) +lisp-simple-string+ +lisp-abstract-string+))) - (compile-form arg1 'stack nil) - (emit-checkcast class) - (compile-form arg2 'stack :int) - (compile-form arg3 'stack :char) - (when target - (emit 'dup) - (emit-move-from-stack value-register :char)) + (with-operand-accumulation + ((compile-operand arg1 nil class) + (compile-operand arg2 :int) + (accumulate-operand (:char + :unsafe-p (some-nested-block + #'node-opstack-unsafe-p + (find-enclosed-blocks arg3))) + (compile-form arg3 'stack :char) + (when target + (emit 'dup) + (emit-move-from-stack value-register :char))))) (maybe-emit-clear-values arg1 arg2 arg3) (emit-invokevirtual class "setCharAt" '(:int :char) nil) (when target @@ -5868,8 +5891,10 @@ (neq representation :char)) ; FIXME (let ((arg1 (%cadr form)) (arg2 (%caddr form))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int))) + (maybe-emit-clear-values arg1 arg2) (emit-invokevirtual +lisp-object+ "SVREF" '(:int) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation))) @@ -5883,9 +5908,11 @@ (arg3 (fourth form)) (*register* *register*) (value-register (when target (allocate-register nil)))) - (compile-form arg1 'stack nil) ;; vector - (compile-form arg2 'stack :int) ;; index - (compile-form arg3 'stack nil) ;; new value + (with-operand-accumulation + ((compile-operand arg1 nil) ;; vector + (compile-operand arg2 :int) ;; intex + (compile-operand arg3 nil) ;; new value + )) (when value-register (emit 'dup) (emit-move-from-stack value-register nil)) @@ -6072,11 +6099,13 @@ (<= 0 arg2 3)) (let* ((*register* *register*) (value-register (when target (allocate-register nil)))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg3 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg3 nil))) (when value-register (emit 'dup) (astore value-register)) + (maybe-emit-clear-values arg1 arg3) (emit-invokevirtual +lisp-object+ (format nil "setSlotValue_~D" arg2) (lisp-object-arg-types 1) nil) @@ -6087,13 +6116,16 @@ ((fixnump arg2) (let* ((*register* *register*) (value-register (when target (allocate-register nil)))) - (compile-form arg1 'stack nil) - (emit-push-constant-int arg2) - (compile-form arg3 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg3 nil))) (maybe-emit-clear-values arg1 arg3) (when value-register (emit 'dup) (astore value-register)) + (emit-push-constant-int arg2) + (emit 'swap) ;; prevent the integer + ;; from being pushed, saved and restored (emit-invokevirtual +lisp-object+ "setSlotValue" (list :int +lisp-object+) nil) (when value-register @@ -6335,10 +6367,10 @@ (defun p2-set (form target representation) (cond ((and (check-arg-count form 2) (eq (derive-type (%cadr form)) 'SYMBOL)) - (emit-push-current-thread) - (compile-form (%cadr form) 'stack nil) - (emit-checkcast +lisp-symbol+) - (compile-form (%caddr form) 'stack nil) + (with-operand-accumulation + ((emit-thread-operand) + (compile-operand (%cadr form) nil +lisp-symbol+) + (compile-operand (%caddr form) nil))) (maybe-emit-clear-values (%cadr form) (%caddr form)) (emit-invokevirtual +lisp-thread+ "setSpecialVariable" (list +lisp-symbol+ +lisp-object+) +lisp-object+) @@ -6355,17 +6387,17 @@ (variable (find-visible-variable name)) (value-form (%caddr form))) (when (or (null variable) - (variable-special-p variable)) + (variable-special-p variable)) ;; We're setting a special variable. (cond ((and variable (variable-binding-register variable) (eq (variable-compiland variable) *current-compiland*) (not (enclosed-by-runtime-bindings-creating-block-p (variable-block variable)))) - ;; ### choose this compilation order to prevent - ;; with-operand-accumulation + ;; choose this compilation order to prevent + ;; with-operand-accumulation (compile-forms-and-maybe-emit-clear-values value-form 'stack nil) - (emit 'dup) + (emit 'dup) (aload (variable-binding-register variable)) (emit 'swap) (emit-putfield +lisp-special-binding+ "value" @@ -6375,24 +6407,24 @@ (= (length value-form) 3) (var-ref-p (third value-form)) (eq (variable-name (var-ref-variable (third value-form))) - name)) - (with-operand-accumulation - ((emit-thread-operand) - (emit-load-externalized-object-operand name) - (compile-operand (second value-form) nil) - (maybe-emit-clear-values (second value-form))) - (emit-invokevirtual +lisp-thread+ "pushSpecial" - (list +lisp-symbol+ +lisp-object+) - +lisp-object+))) + name)) + (with-operand-accumulation + ((emit-thread-operand) + (emit-load-externalized-object-operand name) + (compile-operand (second value-form) nil) + (maybe-emit-clear-values (second value-form))) + (emit-invokevirtual +lisp-thread+ "pushSpecial" + (list +lisp-symbol+ +lisp-object+) + +lisp-object+))) (t - (with-operand-accumulation - ((emit-thread-operand) - (emit-load-externalized-object-operand name) - (compile-operand value-form nil) - (maybe-emit-clear-values value-form)) - (emit-invokevirtual +lisp-thread+ "setSpecialVariable" - (list +lisp-symbol+ +lisp-object+) - +lisp-object+)))) + (with-operand-accumulation + ((emit-thread-operand) + (emit-load-externalized-object-operand name) + (compile-operand value-form nil) + (maybe-emit-clear-values value-form)) + (emit-invokevirtual +lisp-thread+ "setSpecialVariable" + (list +lisp-symbol+ +lisp-object+) + +lisp-object+)))) (fix-boxing representation nil) (emit-move-from-stack target representation) (return-from p2-setq)) From ehuelsmann at common-lisp.net Wed Jan 19 22:02:42 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 19 Jan 2011 17:02:42 -0500 Subject: [armedbear-cvs] r13159 - branches/unsafe-p-removal/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Jan 19 17:02:41 2011 New Revision: 13159 Log: Further transition to unsafety detection in pass2. Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Wed Jan 19 17:02:41 2011 @@ -1152,26 +1152,10 @@ (defvar *pass2-unsafe-p-special-treatment-functions* '( - - char-code - java:jclass - java:jconstructor - java:jmethod - char= coerce-to-function cons sys::backq-cons - delete - elt find-class - funcall - function - gensym - get - getf - gethash - gethash1 - sys::%length list sys::backq-list list* @@ -1182,24 +1166,10 @@ lognot logxor max - memq - memql min mod - not - null - or - puthash - read-line stream-element-type - sxhash - symbol-name - symbol-package - symbol-value truncate - values - vector-push-extend - write-8-bits ) "The functions named in the list bound to this variable need to be rewritten if UNSAFE-P returns non-NIL for their Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed Jan 19 17:02:41 2011 @@ -1781,8 +1781,10 @@ (let* ((args (cdr form)) (arg1 (first args)) (arg2 (second args))) - (compile-form arg1 'stack nil) - (compile-form arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokestatic +lisp+ "memq" (lisp-object-arg-types 2) :boolean) (emit-move-from-stack target representation))) @@ -1797,8 +1799,10 @@ (arg1 (first args)) (arg2 (second args)) (type1 (derive-compiler-type arg1))) - (compile-form arg1 'stack nil) - (compile-form arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (cond ((eq type1 'SYMBOL) ; FIXME (emit-invokestatic +lisp+ "memq" (lisp-object-arg-types 2) :boolean)) @@ -1826,13 +1830,12 @@ (arg3 (third args))) (case (length args) ((2 3) - (compile-form arg1 'stack nil) - (compile-form arg2 'stack nil) - (cond ((null arg3) - (maybe-emit-clear-values arg1 arg2)) - (t - (compile-form arg3 'stack nil) - (maybe-emit-clear-values arg1 arg2 arg3))) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (when arg3 + (compile-operand arg3 nil)) + (maybe-emit-clear-values arg1 arg2 arg3))) (emit-invokestatic +lisp+ "get" (lisp-object-arg-types (if arg3 3 2)) +lisp-object+) @@ -1852,9 +1855,11 @@ (let ((arg1 (first args)) (arg2 (second args)) (arg3 (third args))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil - arg3 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (compile-operand arg3 nil) + (maybe-emit-clear-values arg1 arg2 arg3))) (emit-invokestatic +lisp+ "getf" (lisp-object-arg-types 3) +lisp-object+) (fix-boxing representation nil) @@ -1869,10 +1874,10 @@ (eq (derive-type (%caddr form)) 'HASH-TABLE)) (let ((key-form (%cadr form)) (ht-form (%caddr form))) - (compile-form ht-form 'stack nil) - (emit-checkcast +lisp-hash-table+) - (compile-form key-form 'stack nil) - (maybe-emit-clear-values ht-form key-form) + (with-operand-accumulation + ((compile-operand ht-form nil +lisp-hash-table+) + (compile-operand key-form nil) + (maybe-emit-clear-values ht-form key-form))) (emit-invokevirtual +lisp-hash-table+ "gethash1" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) @@ -1887,11 +1892,11 @@ (let ((key-form (%cadr form)) (ht-form (%caddr form)) (value-form (fourth form))) - (compile-form ht-form 'stack nil) - (emit-checkcast +lisp-hash-table+) - (compile-form key-form 'stack nil) - (compile-form value-form 'stack nil) - (maybe-emit-clear-values ht-form key-form value-form) + (with-operand-accumulation + ((compile-operand ht-form nil +lisp-hash-table+) + (compile-operand key-form nil) + (compile-operand value-form nil) + (maybe-emit-clear-values ht-form key-form value-form))) (cond (target (emit-invokevirtual +lisp-hash-table+ "puthash" (lisp-object-arg-types 2) +lisp-object+) @@ -4810,8 +4815,10 @@ (arg2 (second args))) (case arg-count (2 - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil))) + (maybe-emit-clear-values arg1 arg2) (emit 'swap) (cond (target (emit-invokevirtual +lisp-object+ "VECTOR_PUSH_EXTEND" @@ -4887,9 +4894,9 @@ (type2 (derive-compiler-type arg2))) (cond ((and (compiler-subtypep type1 '(UNSIGNED-BYTE 8)) (eq type2 'STREAM)) - (compile-form arg1 'stack :int) - (compile-form arg2 'stack nil) - (emit-checkcast +lisp-stream+) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 nil +lisp-stream+))) (maybe-emit-clear-values arg1 arg2) (emit 'swap) (emit-invokevirtual +lisp-stream+ "_writeByte" '(:int) nil) @@ -4897,8 +4904,9 @@ (emit-push-nil) (emit-move-from-stack target))) ((fixnum-type-p type1) - (compile-form arg1 'stack :int) - (compile-form arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 nil))) (maybe-emit-clear-values arg1 arg2) (emit-invokestatic +lisp+ "writeByte" (list :int +lisp-object+) nil) @@ -5478,9 +5486,9 @@ (type2 (derive-type arg2)) (test (if (memq type1 '(SYMBOL NULL)) 'eq 'eql))) (cond ((subtypep type2 'VECTOR) - (compile-form arg1 'stack nil) - (compile-form arg2 'stack nil) - (emit-checkcast +lisp-abstract-vector+) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil +lisp-abstract-vector+))) (maybe-emit-clear-values arg1 arg2) (emit 'swap) (emit-invokevirtual +lisp-abstract-vector+ @@ -5950,8 +5958,10 @@ (cond ((and (check-arg-count form 2) (fixnum-type-p (derive-compiler-type (third form))) (neq representation :char)) ; FIXME - (compile-form (second form) 'stack nil) - (compile-form (third form) 'stack :int) + (with-operand-accumulation + ((compile-operand (second form) nil) + (compile-operand (third form) :int) + (maybe-emit-clear-values (second form) (third form)))) (emit-invokevirtual +lisp-object+ "elt" '(:int) +lisp-object+) (fix-boxing representation nil) ; FIXME use derived result type (emit-move-from-stack target representation)) @@ -6288,8 +6298,10 @@ (emit-push-nil) (emit 'dup)) (t - (compile-form arg1 'stack nil) - (compile-form arg2 'stack nil)))) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2)))))) (emit-invokevirtual +lisp-thread+ "setValues" (lisp-object-arg-types len) @@ -6297,9 +6309,12 @@ (fix-boxing representation nil) (emit-move-from-stack target)) ((3 4) - (emit-push-current-thread) - (dolist (arg args) - (compile-form arg 'stack nil)) + (with-operand-accumulation + ((emit-thread-operand) + (dolist (arg args) + (compile-operand arg nil)))) + (when (notevery #'single-valued-p args) + (emit-clear-values)) (emit-invokevirtual +lisp-thread+ "setValues" (lisp-object-arg-types len) @@ -6696,14 +6711,17 @@ (emit-move-from-stack target representation) (return-from p2-char=)) (cond ((characterp arg1) - (emit-push-constant-int (char-code arg1)) - (compile-forms-and-maybe-emit-clear-values arg2 'stack :char)) + ;; prevent need for with-operand-accumulation: reverse args + (compile-forms-and-maybe-emit-clear-values arg2 'stack :char) + (emit-push-constant-int (char-code arg1))) ((characterp arg2) (compile-forms-and-maybe-emit-clear-values arg1 'stack :char) (emit-push-constant-int (char-code arg2))) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack :char - arg2 'stack :char))) + (with-operand-accumulation + ((compile-operand arg1 :char) + (compile-operand arg2 :char) + (maybe-emit-clear-values arg1 arg2))))) (let ((LABEL1 (gensym)) (LABEL2 (gensym))) (emit 'if_icmpeq LABEL1) From ehuelsmann at common-lisp.net Thu Jan 20 12:20:33 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 20 Jan 2011 07:20:33 -0500 Subject: [armedbear-cvs] r13160 - branches/unsafe-p-removal/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jan 20 07:20:29 2011 New Revision: 13160 Log: Further transition to unsafety detection in pass2. Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Thu Jan 20 07:20:29 2011 @@ -1152,24 +1152,10 @@ (defvar *pass2-unsafe-p-special-treatment-functions* '( - coerce-to-function - cons - sys::backq-cons - find-class - list - sys::backq-list - list* - sys::backq-list* - load-time-value logand logior lognot logxor - max - min - mod - stream-element-type - truncate ) "The functions named in the list bound to this variable need to be rewritten if UNSAFE-P returns non-NIL for their Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Jan 20 07:20:29 2011 @@ -760,13 +760,16 @@ (push register *saved-operands*) (emit-move-from-stack register (variable-representation variable))))))) +(defun emit-register-operand (register representation) + (push representation *operand-representations*) + (cond (*saved-operands* + (push register *saved-operands*)) + (t + (emit-push-register register representation)))) + (defun emit-thread-operand () - (push nil *operand-representations*) - (emit-push-current-thread) - (when *saved-operands* - (let ((register (allocate-register nil))) - (push register *saved-operands*) - (emit 'astore register)))) + (ensure-thread-var-initialized) + (emit-register-operand *thread* nil)) (defun emit-load-externalized-object-operand (object) (push nil *operand-representations*) @@ -3955,15 +3958,26 @@ (define-inlined-function p2-cons (form target representation) ((check-arg-count form 2)) - (emit-new +lisp-cons+) - (emit 'dup) (let* ((args (%cdr form)) (arg1 (%car args)) - (arg2 (%cadr args))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil)) - (emit-invokespecial-init +lisp-cons+ (lisp-object-arg-types 2)) - (emit-move-from-stack target)) + (arg2 (%cadr args)) + (cons-register (when (some-nested-block #'node-opstack-unsafe-p + (find-enclosed-blocks args)) + (allocate-register nil)))) + (emit-new +lisp-cons+) + (if cons-register + (astore cons-register) + (emit 'dup)) + (with-operand-accumulation + ((when cons-register + (emit-register-operand cons-register nil)) + (compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) + (emit-invokespecial-init +lisp-cons+ (lisp-object-arg-types 2)) + (when cons-register + (emit-push-register cons-register nil)) + (emit-move-from-stack target))) (defun compile-progn (form target representation) (compile-progn-body (cdr form) target) @@ -4711,19 +4725,25 @@ (cond ((and (eq representation :int) (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit-invokestatic +lisp+ "mod" '(:int :int) :int) (emit-move-from-stack target representation)) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "MOD" '(:int) +lisp-object+) (fix-boxing representation nil) ; FIXME use derived result type (emit-move-from-stack target representation)) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "MOD" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) ; FIXME use derived result type @@ -4798,8 +4818,10 @@ (emit-move-from-stack target representation)) (2 (let ((arg2 (second args))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :boolean) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :boolean) + (maybe-emit-clear-values arg1 arg2))) (emit-invokestatic +lisp-class+ "findClass" (list +lisp-object+ :boolean) +lisp-object+) (fix-boxing representation nil) @@ -5528,7 +5550,9 @@ (cons-heads (if list-star-p (butlast args 1) args))) - (cond ((>= 4 length 1) + (cond ((and (not (some-nested-block #'node-opstack-unsafe-p + (find-enclosed-blocks args))) + (>= 4 length 1)) (dolist (cons-head cons-heads) (emit-new +lisp-cons+) (emit 'dup) @@ -5628,8 +5652,10 @@ (3 (let* ((op (%car form)) (args (%cdr form)) (arg1 (%car args)) - (arg2 (%cadr args))) + (arg2 (%cadr args)) + (*register* *register*)) (when (null target) + ;; compile for effect (compile-forms-and-maybe-emit-clear-values arg1 nil nil arg2 nil nil) (return-from p2-min/max)) @@ -5639,38 +5665,51 @@ (let ((type1 (derive-compiler-type arg1)) (type2 (derive-compiler-type arg2))) (cond ((and (java-long-type-p type1) (java-long-type-p type2)) - (let ((common-rep (if (and (fixnum-type-p type1) - (fixnum-type-p type2)) - :int :long)) - (LABEL1 (gensym))) - (compile-form arg1 'stack common-rep) - (emit-dup common-rep) + (let* ((common-rep (if (and (fixnum-type-p type1) + (fixnum-type-p type2)) + :int :long)) + (LABEL1 (gensym)) + (LABEL2 (gensym)) + (arg1-register (allocate-register common-rep)) + (arg2-register (allocate-register common-rep))) + (compile-form arg1 arg1-register common-rep) (compile-form arg2 'stack common-rep) - (emit-dup common-rep :past common-rep) + (emit-dup common-rep) + (emit-move-from-stack arg2-register common-rep) + (emit-push-register arg1-register common-rep) + ;; note: we've now reversed the arguments on the stack! (emit-numeric-comparison (if (eq op 'max) '<= '>=) common-rep LABEL1) - (emit-swap common-rep common-rep) + (emit-push-register arg1-register common-rep) + (emit 'goto LABEL2) (label LABEL1) - (emit-move-from-stack nil common-rep) + (emit-push-register arg2-register common-rep) + (label LABEL2) (convert-representation common-rep representation) (emit-move-from-stack target representation))) (t - (compile-form arg1 'stack nil) - (emit-dup nil) - (compile-form arg2 'stack nil) - (emit-dup nil :past nil) - (emit-invokevirtual +lisp-object+ - (if (eq op 'max) - "isLessThanOrEqualTo" + (let* ((arg1-register (allocate-register nil)) + (arg2-register (allocate-register nil))) + (compile-form arg1 arg1-register nil) + (compile-form arg2 'stack nil) + (emit-dup nil) + (astore arg2-register) + (emit-push-register arg1-register nil) + (emit-invokevirtual +lisp-object+ + (if (eq op 'max) + "isLessThanOrEqualTo" "isGreaterThanOrEqualTo") - (lisp-object-arg-types 1) :boolean) - (let ((LABEL1 (gensym))) - (emit 'ifeq LABEL1) - (emit 'swap) - (label LABEL1) - (emit 'pop)) - (fix-boxing representation nil) - (emit-move-from-stack target representation)))))) + (lisp-object-arg-types 1) :boolean) + (let ((LABEL1 (gensym)) + (LABEL2 (gensym))) + (emit 'ifeq LABEL1) + (emit-push-register arg1-register nil) + (emit 'goto LABEL2) + (label LABEL1) + (emit-push-register arg2-register nil) + (label LABEL2)) + (fix-boxing representation nil) + (emit-move-from-stack target representation))))))) (t (p2-min/max `(,(car form) (,(car form) ,(second form) ,(third form)) ,@(nthcdr 3 form)) target representation)))) @@ -5948,9 +5987,12 @@ 'truncate (length args)) (compile-function-call form target representation) (return-from p2-truncate))) - (compile-form arg1 'stack nil) - (compile-form arg2 'stack nil) - (emit-invokevirtual +lisp-object+ "truncate" (lisp-object-arg-types 1) +lisp-object+) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil))) + (maybe-emit-clear-values arg1 arg2) + (emit-invokevirtual +lisp-object+ "truncate" + (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) ; FIXME use derived result type (emit-move-from-stack target representation))) @@ -6286,20 +6328,22 @@ (let ((arg (%car args))) (compile-forms-and-maybe-emit-clear-values arg target representation))) (2 - (emit-push-current-thread) (let ((arg1 (%car args)) (arg2 (%cadr args))) (cond ((and (eq arg1 t) (eq arg2 t)) + (emit-push-current-thread) (emit-push-t) (emit 'dup)) ((and (eq arg1 nil) (eq arg2 nil)) + (emit-push-current-thread) (emit-push-nil) (emit 'dup)) (t (with-operand-accumulation - ((compile-operand arg1 nil) + ((emit-thread-operand) + (compile-operand arg1 nil) (compile-operand arg2 nil) (maybe-emit-clear-values arg1 arg2)))))) (emit-invokevirtual +lisp-thread+ From ehuelsmann at common-lisp.net Thu Jan 20 13:31:13 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 20 Jan 2011 08:31:13 -0500 Subject: [armedbear-cvs] r13161 - branches/unsafe-p-removal/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jan 20 08:31:13 2011 New Revision: 13161 Log: Final UNSAFE-P removal. Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Thu Jan 20 08:31:13 2011 @@ -1150,52 +1150,6 @@ (1- (length form)))) (list 'TRULY-THE (%cadr form) (p1 (%caddr form)))) -(defvar *pass2-unsafe-p-special-treatment-functions* - '( - logand - logior - lognot - logxor -) -"The functions named in the list bound to this variable -need to be rewritten if UNSAFE-P returns non-NIL for their -argument list. - -All other function calls are handled by generic function calling -in pass2, which accounts for OPSTACK unsafety itself.") - - - - -(defknown unsafe-p (t) t) -(defun unsafe-p (args) - "Determines whether the args can cause 'stack unsafe situations'. -Returns T if this is the case. - -When a 'stack unsafe situation' is encountered, the stack cannot -be used for temporary storage of intermediary results. This happens -because one of the forms in ARGS causes a local transfer of control -- local GO instruction - which assumes an empty stack, or if one of -the args causes a Java exception handler to be installed, which -- when triggered - clears out the stack. -" - (cond ((node-p args) - (unsafe-p (node-form args))) - ((atom args) - nil) - (t - (case (%car args) - (QUOTE - nil) -;; (LAMBDA -;; nil) - ((RETURN-FROM GO CATCH THROW UNWIND-PROTECT BLOCK) - t) - (t - (dolist (arg args) - (when (unsafe-p arg) - (return t)))))))) - (defknown p1-throw (t) t) (defun p1-throw (form) (list* 'THROW (mapcar #'p1 (cdr form)))) @@ -1207,34 +1161,12 @@ ((and (eq op 'funcall) (listp (car args)) (eq (caar args) 'lambda)) ;;(funcall (lambda (...) ...) ...) (let ((op (car args)) (args (cdr args))) - (expand-function-call-inline form (cadr op) (copy-tree (cddr op)) - args))) + (expand-function-call-inline form (cadr op) (copy-tree (cddr op)) + args))) ((and (listp op) (eq (car op) 'lambda)) ;;((lambda (...) ...) ...) (expand-function-call-inline form (cadr op) (copy-tree (cddr op)) args)) - (t (if (and (member op *pass2-unsafe-p-special-treatment-functions*) - (unsafe-p args)) - (let ((arg1 (car args))) - (cond ((and (consp arg1) (eq (car arg1) 'GO)) - arg1) - (t - (let ((syms ()) - (lets ())) - ;; Preserve the order of evaluation of the arguments! - (dolist (arg args) - (cond ((and (constantp arg) - (not (node-p arg))) - (push arg syms)) - ((and (consp arg) (eq (car arg) 'GO)) - (return-from rewrite-function-call - (list 'LET* (nreverse lets) arg))) - (t - (let ((sym (gensym))) - (push sym syms) - (push (list sym arg) lets))))) - (list 'LET* (nreverse lets) - (list* (car form) (nreverse syms))))))) - form))))) + (t form)))) (defknown p1-function-call (t) t) (defun p1-function-call (form) Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Jan 20 08:31:13 2011 @@ -4437,12 +4437,24 @@ (compile-forms-and-maybe-emit-clear-values arg1 nil nil arg2 target representation)) ((eql (fixnum-constant-value type2) -1) - (compile-forms-and-maybe-emit-clear-values arg1 target representation - arg2 nil nil)) + (let ((target-register + (if (or (not (eq target 'stack)) + (not (some-nested-block #'node-opstack-unsafe-p + (find-enclosed-blocks arg2)))) + target + (allocate-register representation)))) + (compile-form arg1 target-register representation) + (compile-form arg2 nil nil) + (when (and (eq target 'stack) + (not (eq target-register 'stack))) + (emit-push-register target-register)) + (maybe-emit-clear-values arg1 arg2))) ((and (fixnum-type-p type1) (fixnum-type-p type2)) ;; Both arguments are fixnums. - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit 'iand) (convert-representation :int representation) (emit-move-from-stack target representation)) @@ -4451,15 +4463,19 @@ (and (fixnum-type-p type2) (compiler-subtypep type2 'unsigned-byte))) ;; One of the arguments is a positive fixnum. - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit 'iand) (convert-representation :int representation) (emit-move-from-stack target representation)) ((and (java-long-type-p type1) (java-long-type-p type2)) ;; Both arguments are longs. - (compile-forms-and-maybe-emit-clear-values arg1 'stack :long - arg2 'stack :long) + (with-operand-accumulation + ((compile-operand arg1 :long) + (compile-operand arg2 :long) + (maybe-emit-clear-values arg1 arg2))) (emit 'land) (convert-representation :long representation) (emit-move-from-stack target representation)) @@ -4468,29 +4484,37 @@ (and (java-long-type-p type2) (compiler-subtypep type2 'unsigned-byte))) ;; One of the arguments is a positive long. - (compile-forms-and-maybe-emit-clear-values arg1 'stack :long - arg2 'stack :long) + (with-operand-accumulation + ((compile-operand arg1 :long) + (compile-operand arg2 :long) + (maybe-emit-clear-values arg1 arg2))) (emit 'land) (convert-representation :long representation) (emit-move-from-stack target representation)) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "LOGAND" '(:int) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) ((fixnum-type-p type1) ;; arg1 is a fixnum, but arg2 is not - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) ;; swap args (emit 'swap) (emit-invokevirtual +lisp-object+ "LOGAND" '(:int) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "LOGAND" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation result-type) @@ -4521,14 +4545,14 @@ type2 (derive-compiler-type arg2) result-type (derive-compiler-type form)) (cond ((and (fixnum-constant-value type1) (fixnum-constant-value type2)) - (compile-forms-and-maybe-emit-clear-values arg1 nil nil - arg2 nil nil) (compile-constant (logior (fixnum-constant-value type1) (fixnum-constant-value type2)) target representation)) ((and (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit 'ior) (convert-representation :int representation) (emit-move-from-stack target representation)) @@ -4536,16 +4560,32 @@ (compile-forms-and-maybe-emit-clear-values arg1 nil nil arg2 target representation)) ((and (eql (fixnum-constant-value type2) 0) (< *safety* 3)) - (compile-forms-and-maybe-emit-clear-values arg1 target representation - arg2 nil nil)) + (let ((target-register + (if (or (not (eq target 'stack)) + (not (some-nested-block #'node-opstack-unsafe-p + (find-enclosed-blocks arg2)))) + target + (allocate-register representation)))) + (compile-form arg1 target-register representation) + (compile-form arg2 nil nil) + (when (and (eq target 'stack) + (not (eq target-register 'stack))) + (emit-push-register target-register)) + (maybe-emit-clear-values arg1 arg2))) ((or (eq representation :long) (and (java-long-type-p type1) (java-long-type-p type2))) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :long - arg2 'stack :long) + (with-operand-accumulation + ((compile-operand arg1 :long) + (compile-operand arg2 :long) + (maybe-emit-clear-values arg1 arg2))) (emit 'lor) (convert-representation :long representation) (emit-move-from-stack target representation)) ((fixnum-type-p type2) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) (emit-invokevirtual +lisp-object+ "LOGIOR" '(:int) +lisp-object+) @@ -4553,16 +4593,20 @@ (emit-move-from-stack target representation)) ((fixnum-type-p type1) ;; arg1 is of fixnum type, but arg2 is not - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) ;; swap args (emit 'swap) (emit-invokevirtual +lisp-object+ "LOGIOR" '(:int) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "LOGIOR" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation result-type) @@ -4595,28 +4639,33 @@ (setf type1 (derive-compiler-type arg1) type2 (derive-compiler-type arg2) result-type (derive-compiler-type form)) - (cond ((eq representation :int) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) - (emit 'ixor)) - ((and (fixnum-type-p type1) (fixnum-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :int - arg2 'stack :int) + (cond ((or (eq representation :int) + (and (fixnum-type-p type1) (fixnum-type-p type2))) + (with-operand-accumulation + ((compile-operand arg1 :int) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit 'ixor) (convert-representation :int representation)) ((and (java-long-type-p type1) (java-long-type-p type2)) - (compile-forms-and-maybe-emit-clear-values arg1 'stack :long - arg2 'stack :long) + (with-operand-accumulation + ((compile-operand arg1 :long) + (compile-operand arg2 :long) + (maybe-emit-clear-values arg1 arg2))) (emit 'lxor) (convert-representation :long representation)) ((fixnum-type-p type2) - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack :int) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 :int) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "LOGXOR" '(:int) +lisp-object+) (fix-boxing representation result-type)) (t - (compile-forms-and-maybe-emit-clear-values arg1 'stack nil - arg2 'stack nil) + (with-operand-accumulation + ((compile-operand arg1 nil) + (compile-operand arg2 nil) + (maybe-emit-clear-values arg1 arg2))) (emit-invokevirtual +lisp-object+ "LOGXOR" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation result-type))) From ehuelsmann at common-lisp.net Thu Jan 20 13:51:24 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 20 Jan 2011 08:51:24 -0500 Subject: [armedbear-cvs] r13162 - branches/0.24.x/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jan 20 08:51:23 2011 New Revision: 13162 Log: Merge r13135: go back to reflection based method instantiation. Modified: branches/0.24.x/abcl/src/org/armedbear/lisp/FaslClassLoader.java branches/0.24.x/abcl/src/org/armedbear/lisp/Package.java branches/0.24.x/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: branches/0.24.x/abcl/src/org/armedbear/lisp/FaslClassLoader.java ============================================================================== --- branches/0.24.x/abcl/src/org/armedbear/lisp/FaslClassLoader.java (original) +++ branches/0.24.x/abcl/src/org/armedbear/lisp/FaslClassLoader.java Thu Jan 20 08:51:23 2011 @@ -39,23 +39,13 @@ public class FaslClassLoader extends JavaClassLoader { - private final LispObject[] functions; private String baseName; private LispObject loader; //The function used to load FASL functions by number private final JavaObject boxedThis = new JavaObject(this); - public FaslClassLoader(int functionCount, String baseName, boolean useLoaderFunction) { - functions = new LispObject[functionCount]; + public FaslClassLoader(String baseName) { this.baseName = baseName; - if(useLoaderFunction) { - try { - this.loader = (LispObject) loadClass(baseName + "_0").newInstance(); - } catch(Exception e) { - //e.printStackTrace(); - Debug.trace("useLoaderFunction = true but couldn't fully init FASL loader ("+baseName+"), will fall back to reflection!"); } - } - } @Override protected Class loadClass(String name, boolean resolve) @@ -119,52 +109,25 @@ try { //Function name is fnIndex + 1 LispObject o = (LispObject) loadClass(baseName + "_" + (fnNumber + 1)).newInstance(); - functions[fnNumber] = o; return o; } catch(Exception e) { - e.printStackTrace(); if(e instanceof ControlTransfer) { throw (ControlTransfer) e; } - throw new RuntimeException(e); + Debug.trace(e); + return error(new LispError("Compiled function can't be loaded: " + baseName + "_" + (fnNumber + 1) + " " + Symbol.LOAD_TRUENAME.symbolValue())); } } - public LispObject getFunction(int fnNumber) { - if(fnNumber >= functions.length) { - return error(new LispError("Compiled function not found: " + baseName + "_" + (fnNumber + 1) + " " + Symbol.LOAD_TRUENAME.symbolValue())); - } - LispObject o = functions[fnNumber]; - if(o == null) { - if(loader != null) { - loader.execute(boxedThis, Fixnum.getInstance(fnNumber)); - return functions[fnNumber]; - } else { //Fallback to reflection - return loadFunction(fnNumber); - } - } else { - return o; - } - } - - public LispObject putFunction(int fnNumber, LispObject fn) { - functions[fnNumber] = fn; - return fn; - } - private static final Primitive MAKE_FASL_CLASS_LOADER = new pf_make_fasl_class_loader(); private static final class pf_make_fasl_class_loader extends Primitive { pf_make_fasl_class_loader() { - super("make-fasl-class-loader", PACKAGE_SYS, false, "function-count base-name"); + super("make-fasl-class-loader", PACKAGE_SYS, false, "base-name"); } @Override - public LispObject execute(LispObject functionCount, LispObject baseName) { - return execute(functionCount, baseName, T); + public LispObject execute(LispObject baseName) { + return new FaslClassLoader(baseName.getStringValue()).boxedThis; } - @Override - public LispObject execute(LispObject functionCount, LispObject baseName, LispObject init) { - return new FaslClassLoader(functionCount.intValue(), baseName.getStringValue(), init != NIL).boxedThis; - } }; private static final Primitive GET_FASL_FUNCTION = new pf_get_fasl_function(); @@ -176,7 +139,7 @@ @Override public LispObject execute(LispObject loader, LispObject fnNumber) { FaslClassLoader l = (FaslClassLoader) loader.javaInstance(FaslClassLoader.class); - return l.getFunction(fnNumber.intValue()); + return l.loadFunction(fnNumber.intValue()); } }; Modified: branches/0.24.x/abcl/src/org/armedbear/lisp/Package.java ============================================================================== --- branches/0.24.x/abcl/src/org/armedbear/lisp/Package.java (original) +++ branches/0.24.x/abcl/src/org/armedbear/lisp/Package.java Thu Jan 20 08:51:23 2011 @@ -161,12 +161,14 @@ public final synchronized boolean delete() { if (name != null) { + if(useList instanceof Cons) { LispObject usedPackages = useList; while (usedPackages != NIL) { Package pkg = (Package) usedPackages.car(); unusePackage(pkg); usedPackages = usedPackages.cdr(); } + } Packages.deletePackage(this); Modified: branches/0.24.x/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- branches/0.24.x/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ branches/0.24.x/abcl/src/org/armedbear/lisp/compile-file.lisp Thu Jan 20 08:51:23 2011 @@ -369,9 +369,7 @@ (when compile-time-too (let ((*load-truename* *output-file-pathname*) (*fasl-loader* (make-fasl-class-loader - *class-number* - (concatenate 'string "org.armedbear.lisp." (base-classname)) - nil))) + (concatenate 'string "org.armedbear.lisp." (base-classname))))) (eval form)))) (declaim (ftype (function (t) t) convert-ensure-method)) @@ -611,10 +609,8 @@ (%stream-terpri out) (when (> *class-number* 0) - (generate-loader-function) (write (list 'setq '*fasl-loader* `(sys::make-fasl-class-loader - ,*class-number* ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out)) (%stream-terpri out)) @@ -661,62 +657,6 @@ (namestring output-file) elapsed)))) (values (truename output-file) warnings-p failure-p))) -(defmacro ncase (expr min max &rest clauses) - "A CASE where all test clauses are numbers ranging from a minimum to a maximum." - ;;Expr is subject to multiple evaluation, but since we only use ncase for - ;;fn-index below, let's ignore it. - (let* ((half (floor (/ (- max min) 2))) - (middle (+ min half))) - (if (> (- max min) 10) - `(if (< ,expr ,middle) - (ncase ,expr ,min ,middle ,@(subseq clauses 0 half)) - (ncase ,expr ,middle ,max ,@(subseq clauses half))) - `(case ,expr , at clauses)))) - -(defconstant +fasl-classloader+ - (jvm::make-jvm-class-name "org.armedbear.lisp.FaslClassLoader")) - -(defun generate-loader-function () - (let* ((basename (base-classname)) - (expr `(lambda (fasl-loader fn-index) - (declare (type (integer 0 256000) fn-index)) - (identity fasl-loader) ;;to avoid unused arg - (jvm::with-inline-code () - (jvm::emit 'jvm::aload 1) - (jvm::emit-invokevirtual jvm::+lisp-object+ "javaInstance" - nil jvm::+java-object+) - (jvm::emit-checkcast +fasl-classloader+) - (jvm::emit 'jvm::iload 2)) - (ncase fn-index 0 ,(1- *class-number*) - ,@(loop - :for i :from 1 :to *class-number* - :collect - (let* ((class (%format nil "org/armedbear/lisp/~A_~A" - basename i)) - (class-name (jvm::make-jvm-class-name class))) - `(,(1- i) - (jvm::with-inline-code () - (jvm::emit-new ,class-name) - (jvm::emit 'jvm::dup) - (jvm::emit-invokespecial-init ,class-name '()) - (jvm::emit-invokevirtual +fasl-classloader+ - "putFunction" - (list :int jvm::+lisp-object+) jvm::+lisp-object+) - (jvm::emit 'jvm::pop)) - t)))))) - (classname (fasl-loader-classname)) - (classfile (namestring (merge-pathnames (make-pathname :name classname :type "cls") - *output-file-pathname*)))) - (jvm::with-saved-compiler-policy - (jvm::with-file-compilation - (with-open-file - (f classfile - :direction :output - :element-type '(unsigned-byte 8) - :if-exists :supersede) - (jvm:compile-defun nil expr *compile-file-environment* - classfile f nil)))))) - (defun compile-file-if-needed (input-file &rest allargs &key force-compile &allow-other-keys) (setf input-file (truename input-file)) From ehuelsmann at common-lisp.net Thu Jan 20 13:56:23 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 20 Jan 2011 08:56:23 -0500 Subject: [armedbear-cvs] r13163 - trunk/abcl Message-ID: Author: ehuelsmann Date: Thu Jan 20 08:56:22 2011 New Revision: 13163 Log: Update CHANGES. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Thu Jan 20 08:56:22 2011 @@ -23,6 +23,9 @@ Fixes ----- +* [svn r13135] Fix the problem that FASLs can contain + a limited number of functions. + * [svn r13117][ticket #117] Fix stack inconsistency error. * [svn r13018][ticket #114] Fix strange backtrace growth. From ehuelsmann at common-lisp.net Thu Jan 20 13:57:05 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 20 Jan 2011 08:57:05 -0500 Subject: [armedbear-cvs] r13164 - branches/0.24.x/abcl Message-ID: Author: ehuelsmann Date: Thu Jan 20 08:57:02 2011 New Revision: 13164 Log: Backport CHANGES. Modified: branches/0.24.x/abcl/CHANGES Modified: branches/0.24.x/abcl/CHANGES ============================================================================== --- branches/0.24.x/abcl/CHANGES (original) +++ branches/0.24.x/abcl/CHANGES Thu Jan 20 08:57:02 2011 @@ -23,6 +23,9 @@ Fixes ----- +* [svn r13135] Fix the problem that FASLs can contain + a limited number of functions. + * [svn r13117][ticket #117] Fix stack inconsistency error. * [svn r13018][ticket #114] Fix strange backtrace growth. From ehuelsmann at common-lisp.net Thu Jan 20 14:08:24 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 20 Jan 2011 09:08:24 -0500 Subject: [armedbear-cvs] r13165 - trunk/abcl Message-ID: Author: ehuelsmann Date: Thu Jan 20 09:08:23 2011 New Revision: 13165 Log: Update README. Modified: trunk/abcl/README Modified: trunk/abcl/README ============================================================================== --- trunk/abcl/README (original) +++ trunk/abcl/README Thu Jan 20 09:08:23 2011 @@ -45,10 +45,10 @@ which should result in output like the following - Armed Bear Common Lisp 0.19.1 - Java 1.6.0_14 Sun Microsystems Inc. + Armed Bear Common Lisp 0.25.0 + Java 1.6.0_21 Sun Microsystems Inc. Java HotSpot(TM) Client VM - Low-level initialization completed in 0.9 seconds. + Low-level initialization completed in 0.3 seconds. Startup completed in 2.294 seconds. Type ":help" for a list of available commands. CL-USER(1): @@ -60,7 +60,7 @@ There are three ways to build ABCL from the source release with the preferred (and most tested way) is to being to use the Ant build tool: -* Use the Ant build tool for Java environments. +* Use the Ant build tool for Java environments. * Use the Netbeans 6.x IDE to open ABCL as a project. @@ -72,6 +72,10 @@ tested). Just the JRE isn't enough, as you need the Java compiler ('javac') to compile the Java source of the ABCL implementation. +When deploying ABCL, the JDK isn't a requirement for the installation +site: ABCL compiles directly to byte code, avoiding the need for the +'javac' compiler in deployment environments. + Using Ant --------- @@ -84,10 +88,10 @@ Then simply executing - unix$ ant + unix$ ant or - cmd$ ant.bat + cmd$ ant.bat from the directory containing this README file will create an executable wrapper ('abcl' under UNIX, 'abcl.bat' under Windows). Use @@ -136,7 +140,7 @@ After a successful build, you may use 'abcl.bat' on Windows or 'abcl' on Unix to start ABCL. Note that this wrappers contain absolute paths, so you'll need to edit them if you move things around after the -build. +build. If you're developing on ABCL, you may want to use @@ -150,14 +154,14 @@ This invokes javac separately for each .java file, which avoids running into limitations on command line length (but is a lot slower). - + ** Building from another Lisp by hand There is also an ASDF definition in 'abcl.asd' for the BUILD-ABCL which can be used to load the necessary Lisp definitions, after which CL-USER> (build-abcl:build-abcl :clean t :full t) - + will build ABCL. If ASDF isn't present, simply LOAD the 'customizations.lisp' and 'build-abcl.lisp' files to achieve the same effect as loading the ASDF definition. @@ -168,21 +172,15 @@ A lot of (renewed) energy has been spent to make ABCL a compliant and practically useable Common Lisp implementation. Because of this, -ABCL 0.19.1 now fails only 29 out of 21702 tests in the ANSI CL test -suite. Next to that, the fail count of the Maxima test suite has been -reduced to only 5 - rounding errors. - -ABCL's CLOS does not handle on-the-fly redefinition of classes -correctly. Quite a bit of energy has been spent in versions 0.16.0 and -0.17.0 to improve CLOS performance. There is no support for the long -form of DEFINE-METHOD-COMBINATION, and certain other required CLOS -features are also missing. Enough CLOS is there to run -ASDF2 and CL-PPCRE. +ABCL 0.25.0 now fails only 28 out of 21702 tests in the ANSI CL test +suite. In addition, Maxima's test suite runs without failures now +and ABCL's CLOS complete, with the exception of the long form of +DEFINE-METHOD-COMBINATION - which is an ongoing effort. There is no MOP worth mentioning. -Patches to address any of the issues mentioned above will be gladly -accepted. +Patches to address any of the issues mentioned above will +be gladly accepted. Please report problems to the development mailing list: @@ -192,4 +190,4 @@ On behalf of all ABCL development team and contributors, Erik Huelsmann -March 20, 2010 +January 20, 2011 From mevenson at common-lisp.net Fri Jan 21 14:13:50 2011 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 21 Jan 2011 09:13:50 -0500 Subject: [armedbear-cvs] r13166 - trunk/abcl Message-ID: Author: mevenson Date: Fri Jan 21 09:13:48 2011 New Revision: 13166 Log: Smooth over more nits in the README. Modified: trunk/abcl/README Modified: trunk/abcl/README ============================================================================== --- trunk/abcl/README (original) +++ trunk/abcl/README Fri Jan 21 09:13:48 2011 @@ -2,15 +2,15 @@ =================== Armed Bear Common Lisp is an implementation of ANSI Common Lisp that -runs in a Java virtual machine. It compiles its code to Java byte -code. +runs in a Java virtual machine. It compiles Lisp code directly to +Java byte code. LICENSE ======= Armed Bear Common Lisp is distributed under the GNU General Public -License with classpath exception (described below). +License with a classpath exception (see "Classpath Exception" below). A copy of GNU General Public License (GPL) is included in this distribution, in the file COPYING. @@ -20,6 +20,8 @@ conditions of the GNU General Public License cover the whole combination. +** Classpath Exception + As a special exception, the copyright holders of this software give you permission to link this software with independent modules to produce an executable, regardless of the license terms of these @@ -38,8 +40,8 @@ After you have downloaded a binary release archive unpack it into its own directory. To run ABCL directly from this directory, make sure -Java (version 1.5 or up) is in your shell's path. Then issue following -command +Java (version 1.5 or up) is in your shell's path. Then issue the +following command: cmd$ java -jar abcl.jar @@ -72,9 +74,10 @@ tested). Just the JRE isn't enough, as you need the Java compiler ('javac') to compile the Java source of the ABCL implementation. -When deploying ABCL, the JDK isn't a requirement for the installation -site: ABCL compiles directly to byte code, avoiding the need for the -'javac' compiler in deployment environments. +Note that when deploying ABCL having JDK isn't a requirement for the +installation site, just the equivalent JRE, as ABCL compiles directly +to byte code, avoiding the need for the 'javac' compiler in deployment +environments. Using Ant @@ -88,10 +91,10 @@ Then simply executing - unix$ ant + unix$ ant or - cmd$ ant.bat + dos> ant.bat from the directory containing this README file will create an executable wrapper ('abcl' under UNIX, 'abcl.bat' under Windows). Use @@ -118,7 +121,7 @@ two methods, but it still may be of interest to those who absolutely don't want to know anything about Java. -First, copy the file 'customizations.lisp.in' to customization.lisp', +First, copy the file 'customizations.lisp.in' to 'customization.lisp', in the directory containing this README file, editing to suit your situation, paying attention to the comments in the file. The critical step is to have Lisp special variable '*JDK*' point to the root of the @@ -137,10 +140,9 @@ unix$ ./build-from-lisp.sh sbcl -After a successful build, you may use 'abcl.bat' on Windows or 'abcl' -on Unix to start ABCL. Note that this wrappers contain absolute -paths, so you'll need to edit them if you move things around after the -build. +After a successful build, you may use 'abcl' ('abcl.bat' on Windows) +to start ABCL. Note that this wrappers contain absolute paths, so +you'll need to edit them if you move things around after the build. If you're developing on ABCL, you may want to use @@ -177,7 +179,7 @@ and ABCL's CLOS complete, with the exception of the long form of DEFINE-METHOD-COMBINATION - which is an ongoing effort. -There is no MOP worth mentioning. +The MOP implementation is incomplete. Patches to address any of the issues mentioned above will be gladly accepted. From ehuelsmann at common-lisp.net Fri Jan 21 20:57:59 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 21 Jan 2011 15:57:59 -0500 Subject: [armedbear-cvs] r13167 - branches/0.24.x/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Jan 21 15:57:57 2011 New Revision: 13167 Log: Merge r13148 and r13149: Additional changes to use reflection based function instantiation. Modified: branches/0.24.x/abcl/src/org/armedbear/lisp/FaslClassLoader.java branches/0.24.x/abcl/src/org/armedbear/lisp/Lisp.java branches/0.24.x/abcl/src/org/armedbear/lisp/Load.java branches/0.24.x/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: branches/0.24.x/abcl/src/org/armedbear/lisp/FaslClassLoader.java ============================================================================== --- branches/0.24.x/abcl/src/org/armedbear/lisp/FaslClassLoader.java (original) +++ branches/0.24.x/abcl/src/org/armedbear/lisp/FaslClassLoader.java Fri Jan 21 15:57:57 2011 @@ -39,8 +39,7 @@ public class FaslClassLoader extends JavaClassLoader { - private String baseName; - private LispObject loader; //The function used to load FASL functions by number + private final String baseName; private final JavaObject boxedThis = new JavaObject(this); public FaslClassLoader(String baseName) { @@ -63,13 +62,13 @@ String internalName = "org/armedbear/lisp/" + name; Class c = this.findLoadedClass(internalName); - if (c == null) + if (c == null) { c = findClass(name); - + } if (c != null) { - if (resolve) + if (resolve) { resolveClass(c); - + } return c; } } @@ -108,8 +107,10 @@ public LispObject loadFunction(int fnNumber) { try { //Function name is fnIndex + 1 - LispObject o = (LispObject) loadClass(baseName + "_" + (fnNumber + 1)).newInstance(); - return o; + String name = baseName + "_" + (fnNumber + 1); + Function f = (Function) loadClass(name).newInstance(); + f.setClassBytes(getFunctionClassBytes(name)); + return f; } catch(Exception e) { if(e instanceof ControlTransfer) { throw (ControlTransfer) e; } Debug.trace(e); @@ -128,6 +129,12 @@ return new FaslClassLoader(baseName.getStringValue()).boxedThis; } + @Override + //TODO delete this next time the fasl version is bumbed + public LispObject execute(LispObject unused1, LispObject baseName, LispObject unused2) { + return execute(baseName); + } + }; private static final Primitive GET_FASL_FUNCTION = new pf_get_fasl_function(); Modified: branches/0.24.x/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- branches/0.24.x/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ branches/0.24.x/abcl/src/org/armedbear/lisp/Lisp.java Fri Jan 21 15:57:57 2011 @@ -1284,6 +1284,7 @@ try { if (input == null) { Debug.trace("Pathname: " + name); + Debug.trace("load: " + load); Debug.trace("LOAD_TRUENAME_FASL: " + truenameFasl); Debug.trace("LOAD_TRUENAME: " + truename); Debug.assertTrue(input != null); Modified: branches/0.24.x/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- branches/0.24.x/abcl/src/org/armedbear/lisp/Load.java (original) +++ branches/0.24.x/abcl/src/org/armedbear/lisp/Load.java Fri Jan 21 15:57:57 2011 @@ -342,6 +342,14 @@ // ### *fasl-version* // internal symbol + + /* TODO when bumping the version for any reason, remember to: + * - remove the overload taking 3 args in + * FaslClassLoader.MAKE_FASL_CLASS_LOADER + * - remove the extra args (1 and 3, both NIL) passed to + * make-fasl-class-loader in compile-file.lisp + * - delete this comment :) + */ static final Symbol _FASL_VERSION_ = exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(37)); Modified: branches/0.24.x/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- branches/0.24.x/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ branches/0.24.x/abcl/src/org/armedbear/lisp/compile-file.lisp Fri Jan 21 15:57:57 2011 @@ -369,7 +369,9 @@ (when compile-time-too (let ((*load-truename* *output-file-pathname*) (*fasl-loader* (make-fasl-class-loader - (concatenate 'string "org.armedbear.lisp." (base-classname))))) + nil + (concatenate 'string "org.armedbear.lisp." (base-classname)) + nil))) (eval form)))) (declaim (ftype (function (t) t) convert-ensure-method)) @@ -611,7 +613,9 @@ (when (> *class-number* 0) (write (list 'setq '*fasl-loader* `(sys::make-fasl-class-loader - ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out)) + nil + ,(concatenate 'string "org.armedbear.lisp." (base-classname)) + nil)) :stream out)) (%stream-terpri out)) From ehuelsmann at common-lisp.net Fri Jan 21 22:12:09 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 21 Jan 2011 17:12:09 -0500 Subject: [armedbear-cvs] r13168 - in branches/0.24.x/abcl/src/org/armedbear/lisp: . java/swing Message-ID: Author: ehuelsmann Date: Fri Jan 21 17:12:08 2011 New Revision: 13168 Log: Merge r13141-13146 and r13156: Make sure ABCL doesn't call System.exit() in order to be a well-behaving library. Added: branches/0.24.x/abcl/src/org/armedbear/lisp/IntegrityError.java - copied unchanged from r13146, /trunk/abcl/src/org/armedbear/lisp/IntegrityError.java branches/0.24.x/abcl/src/org/armedbear/lisp/ProcessingTerminated.java - copied, changed from r13146, /trunk/abcl/src/org/armedbear/lisp/ProcessingTerminated.java Modified: branches/0.24.x/abcl/src/org/armedbear/lisp/Autoload.java branches/0.24.x/abcl/src/org/armedbear/lisp/Extensions.java branches/0.24.x/abcl/src/org/armedbear/lisp/Interpreter.java branches/0.24.x/abcl/src/org/armedbear/lisp/Lisp.java branches/0.24.x/abcl/src/org/armedbear/lisp/Main.java branches/0.24.x/abcl/src/org/armedbear/lisp/Primitives.java branches/0.24.x/abcl/src/org/armedbear/lisp/java/swing/REPLConsole.java Modified: branches/0.24.x/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- branches/0.24.x/abcl/src/org/armedbear/lisp/Autoload.java (original) +++ branches/0.24.x/abcl/src/org/armedbear/lisp/Autoload.java Fri Jan 21 17:12:08 2011 @@ -141,7 +141,7 @@ if (symbol != null) { if (symbol.getSymbolFunction() instanceof Autoload) { Debug.trace("Unable to autoload " + symbol.writeToString()); - System.exit(-1); + throw new IntegrityError(); } } } Modified: branches/0.24.x/abcl/src/org/armedbear/lisp/Extensions.java ============================================================================== --- branches/0.24.x/abcl/src/org/armedbear/lisp/Extensions.java (original) +++ branches/0.24.x/abcl/src/org/armedbear/lisp/Extensions.java Fri Jan 21 17:12:08 2011 @@ -200,8 +200,7 @@ @Override public LispObject execute() { - exit(0); - return LispThread.currentThread().nothing(); + throw new ProcessingTerminated(); } @Override public LispObject execute(LispObject first, LispObject second) @@ -213,8 +212,7 @@ if (second instanceof Fixnum) status = ((Fixnum)second).value; } - exit(status); - return LispThread.currentThread().nothing(); + throw new ProcessingTerminated(status); } } @@ -229,8 +227,7 @@ { ((Stream)Symbol.STANDARD_OUTPUT.getSymbolValue())._finishOutput(); ((Stream)Symbol.ERROR_OUTPUT.getSymbolValue())._finishOutput(); - exit(0); - return LispThread.currentThread().nothing(); + throw new ProcessingTerminated(); } @Override public LispObject execute(LispObject first, LispObject second) @@ -241,8 +238,7 @@ if (second instanceof Fixnum) status = ((Fixnum)second).value; } - exit(status); - return LispThread.currentThread().nothing(); + throw new ProcessingTerminated(status); } } Modified: branches/0.24.x/abcl/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- branches/0.24.x/abcl/src/org/armedbear/lisp/Interpreter.java (original) +++ branches/0.24.x/abcl/src/org/armedbear/lisp/Interpreter.java Fri Jan 21 17:12:08 2011 @@ -89,7 +89,7 @@ Stream out = getStandardOutput(); out._writeString(help()); out._finishOutput(); - exit(0); + exit(0); // FIXME } if (noinform) _NOINFORM_.setSymbolValue(T); @@ -253,7 +253,7 @@ ++i; } else { System.err.println("No argument supplied to --eval"); - exit(1); + exit(1); // FIXME } } else if (arg.equals("--load") || arg.equals("--load-system-file")) { @@ -261,7 +261,7 @@ ++i; } else { System.err.println("No argument supplied to --load"); - exit(1); + exit(1); // FIXME } } else { arglist = new Cons(args[i], arglist); @@ -301,13 +301,13 @@ sb.append(c.getCondition().writeToString()); sb.append(separator); System.err.print(sb.toString()); - exit(2); + exit(2); // FIXME } ++i; } else { // Shouldn't happen. System.err.println("No argument supplied to --eval"); - exit(1); + exit(1); // FIXME } } else if (arg.equals("--load") || arg.equals("--load-system-file")) { @@ -322,16 +322,17 @@ } else { // Shouldn't happen. System.err.println("No argument supplied to --load"); - exit(1); + exit(1); // FIXME } } } } if (_BATCH_MODE_.getSymbolValue() == T) { - exit(0); + exit(0); // FIXME } } + @SuppressWarnings("CallToThreadDumpStack") public void run() { final LispThread thread = LispThread.currentThread(); @@ -342,66 +343,80 @@ thread.execute(tplFun); return; } - // We only arrive here if something went wrong and we weren't able - // to load top-level.lisp and run the normal top-level loop. - Stream out = getStandardOutput(); - while (true) { - try { - thread.resetStack(); - thread.clearSpecialBindings(); - out._writeString("* "); - out._finishOutput(); - LispObject object = - getStandardInput().read(false, EOF, false, thread, - Stream.currentReadtable); - if (object == EOF) - break; - out.setCharPos(0); - Symbol.MINUS.setSymbolValue(object); - LispObject result = Lisp.eval(object, new Environment(), thread); - Debug.assertTrue(result != null); - Symbol.STAR_STAR_STAR.setSymbolValue(Symbol.STAR_STAR.getSymbolValue()); - Symbol.STAR_STAR.setSymbolValue(Symbol.STAR.getSymbolValue()); - Symbol.STAR.setSymbolValue(result); - Symbol.PLUS_PLUS_PLUS.setSymbolValue(Symbol.PLUS_PLUS.getSymbolValue()); - Symbol.PLUS_PLUS.setSymbolValue(Symbol.PLUS.getSymbolValue()); - Symbol.PLUS.setSymbolValue(Symbol.MINUS.getSymbolValue()); - out = getStandardOutput(); - out.freshLine(); - LispObject[] values = thread.getValues(); - Symbol.SLASH_SLASH_SLASH.setSymbolValue(Symbol.SLASH_SLASH.getSymbolValue()); - Symbol.SLASH_SLASH.setSymbolValue(Symbol.SLASH.getSymbolValue()); - if (values != null) { - LispObject slash = NIL; - for (int i = values.length; i-- > 0;) - slash = new Cons(values[i], slash); - Symbol.SLASH.setSymbolValue(slash); - for (int i = 0; i < values.length; i++) - out._writeLine(values[i].writeToString()); - } else { - Symbol.SLASH.setSymbolValue(new Cons(result)); - out._writeLine(result.writeToString()); - } - out._finishOutput(); - } - catch (StackOverflowError e) { - getStandardInput().clearInput(); - out._writeLine("Stack overflow"); - } - catch (ControlTransfer c) { - // We're on the toplevel, if this occurs, - // we're toast... - reportError(c, thread); - } - catch (Throwable t) { - getStandardInput().clearInput(); - out.printStackTrace(t); - thread.printBacktrace(); - } - } + } + catch (ProcessingTerminated e) { + throw e; + } + catch (IntegrityError e) { + return; } catch (Throwable t) { t.printStackTrace(); + return; + } + + // We only arrive here if something went wrong and we weren't able + // to load top-level.lisp and run the normal top-level loop. + Stream out = getStandardOutput(); + while (true) { + try { + thread.resetStack(); + thread.clearSpecialBindings(); + out._writeString("* "); + out._finishOutput(); + LispObject object = + getStandardInput().read(false, EOF, false, thread, + Stream.currentReadtable); + if (object == EOF) + break; + out.setCharPos(0); + Symbol.MINUS.setSymbolValue(object); + LispObject result = Lisp.eval(object, new Environment(), thread); + Debug.assertTrue(result != null); + Symbol.STAR_STAR_STAR.setSymbolValue(Symbol.STAR_STAR.getSymbolValue()); + Symbol.STAR_STAR.setSymbolValue(Symbol.STAR.getSymbolValue()); + Symbol.STAR.setSymbolValue(result); + Symbol.PLUS_PLUS_PLUS.setSymbolValue(Symbol.PLUS_PLUS.getSymbolValue()); + Symbol.PLUS_PLUS.setSymbolValue(Symbol.PLUS.getSymbolValue()); + Symbol.PLUS.setSymbolValue(Symbol.MINUS.getSymbolValue()); + out = getStandardOutput(); + out.freshLine(); + LispObject[] values = thread.getValues(); + Symbol.SLASH_SLASH_SLASH.setSymbolValue(Symbol.SLASH_SLASH.getSymbolValue()); + Symbol.SLASH_SLASH.setSymbolValue(Symbol.SLASH.getSymbolValue()); + if (values != null) { + LispObject slash = NIL; + for (int i = values.length; i-- > 0;) + slash = new Cons(values[i], slash); + Symbol.SLASH.setSymbolValue(slash); + for (int i = 0; i < values.length; i++) + out._writeLine(values[i].writeToString()); + } else { + Symbol.SLASH.setSymbolValue(new Cons(result)); + out._writeLine(result.writeToString()); + } + out._finishOutput(); + } + catch (StackOverflowError e) { + getStandardInput().clearInput(); + out._writeLine("Stack overflow"); + } + catch (ControlTransfer c) { + // We're on the toplevel, if this occurs, + // we're toast... + reportError(c, thread); + } + catch (ProcessingTerminated e) { + throw e; + } + catch (IntegrityError e) { + return; + } + catch (Throwable t) { + getStandardInput().clearInput(); + out.printStackTrace(t); + thread.printBacktrace(); + } } } Modified: branches/0.24.x/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- branches/0.24.x/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ branches/0.24.x/abcl/src/org/armedbear/lisp/Lisp.java Fri Jan 21 17:12:08 2011 @@ -289,6 +289,14 @@ { throw c; } + catch (ProcessingTerminated c) + { + throw c; + } + catch (IntegrityError c) + { + throw c; + } catch (Throwable t) // ControlTransfer handled above { Debug.trace(t); Modified: branches/0.24.x/abcl/src/org/armedbear/lisp/Main.java ============================================================================== --- branches/0.24.x/abcl/src/org/armedbear/lisp/Main.java (original) +++ branches/0.24.x/abcl/src/org/armedbear/lisp/Main.java Fri Jan 21 17:12:08 2011 @@ -30,26 +30,27 @@ * obligated to do so. If you do not wish to do so, delete this * exception statement from your version. */ - package org.armedbear.lisp; -public final class Main -{ - public static final long startTimeMillis = System.currentTimeMillis(); +public final class Main { + + public static final long startTimeMillis = System.currentTimeMillis(); + + public static void main(final String[] args) { + // Run the interpreter in a secondary thread so we can control the stack + // size. + Runnable r = new Runnable() { - public static void main(final String[] args) - { - // Run the interpreter in a secondary thread so we can control the stack - // size. - Runnable r = new Runnable() - { - public void run() - { - Interpreter interpreter = Interpreter.createDefaultInstance(args); - if (interpreter != null) - interpreter.run(); - } - }; - new Thread(null, r, "interpreter", 4194304L).start(); - } + public void run() { + try { + Interpreter interpreter = Interpreter.createDefaultInstance(args); + if (interpreter != null) + interpreter.run(); + } catch (ProcessingTerminated e) { + System.exit(e.getStatus()); + } + } + }; + new Thread(null, r, "interpreter", 4194304L).start(); + } } Modified: branches/0.24.x/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- branches/0.24.x/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ branches/0.24.x/abcl/src/org/armedbear/lisp/Primitives.java Fri Jan 21 17:12:08 2011 @@ -1582,7 +1582,7 @@ @Override public LispObject execute(LispObject[] args) { - Error e = new Error(); + Error e = new IntegrityError(); e.printStackTrace(); @@ -1595,9 +1595,7 @@ for (LispObject a : args) System.out.println(a.writeToString()); - //###FIXME: Bail out, but do it nicer... - exit(1); - return NIL; + throw e; } }; Copied: branches/0.24.x/abcl/src/org/armedbear/lisp/ProcessingTerminated.java (from r13146, /trunk/abcl/src/org/armedbear/lisp/ProcessingTerminated.java) ============================================================================== --- /trunk/abcl/src/org/armedbear/lisp/ProcessingTerminated.java (original) +++ branches/0.24.x/abcl/src/org/armedbear/lisp/ProcessingTerminated.java Fri Jan 21 17:12:08 2011 @@ -52,7 +52,7 @@ this.status = status; } - int getStatus() { + public int getStatus() { return status; } } Modified: branches/0.24.x/abcl/src/org/armedbear/lisp/java/swing/REPLConsole.java ============================================================================== --- branches/0.24.x/abcl/src/org/armedbear/lisp/java/swing/REPLConsole.java (original) +++ branches/0.24.x/abcl/src/org/armedbear/lisp/java/swing/REPLConsole.java Fri Jan 21 17:12:08 2011 @@ -302,7 +302,7 @@ repl = Interpreter.createInstance().eval("#'top-level::top-level-loop"); } catch (Throwable e) { e.printStackTrace(); - exit(1); + System.exit(1); // Ok. We haven't done anything useful yet. } final REPLConsole d = new REPLConsole(repl); final JTextComponent txt = new JTextArea(d); From ehuelsmann at common-lisp.net Fri Jan 21 22:18:23 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 21 Jan 2011 17:18:23 -0500 Subject: [armedbear-cvs] r13169 - trunk/abcl Message-ID: Author: ehuelsmann Date: Fri Jan 21 17:18:21 2011 New Revision: 13169 Log: Update CHANGES for the latest merge. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Fri Jan 21 17:18:21 2011 @@ -52,7 +52,10 @@ Changes ------- -* [svn r13120] Register each compiler node with its parent. +* [svn r13141-13146,13156] Make ABCL a well behaving library to better + support embedding: NEVER call System.exit() again. Instead, ABCL now + throws org.armedbear.lisp.ProcessingTerminated and + org.armedbear.lisp.IntegrityError. * [svn r13111] Added a "tools" directory available in SVN repository to contain tools for developing ABCL in various states. The first From ehuelsmann at common-lisp.net Fri Jan 21 22:18:41 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 21 Jan 2011 17:18:41 -0500 Subject: [armedbear-cvs] r13170 - branches/0.24.x/abcl Message-ID: Author: ehuelsmann Date: Fri Jan 21 17:18:40 2011 New Revision: 13170 Log: Update CHANGES for the latest merge. Modified: branches/0.24.x/abcl/CHANGES Modified: branches/0.24.x/abcl/CHANGES ============================================================================== --- branches/0.24.x/abcl/CHANGES (original) +++ branches/0.24.x/abcl/CHANGES Fri Jan 21 17:18:40 2011 @@ -52,7 +52,10 @@ Changes ------- -* [svn r13120] Register each compiler node with its parent. +* [svn r13141-13146,13156] Make ABCL a well behaving library to better + support embedding: NEVER call System.exit() again. Instead, ABCL now + throws org.armedbear.lisp.ProcessingTerminated and + org.armedbear.lisp.IntegrityError. * [svn r13111] Added a "tools" directory available in SVN repository to contain tools for developing ABCL in various states. The first From mevenson at common-lisp.net Sat Jan 22 10:17:42 2011 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 22 Jan 2011 05:17:42 -0500 Subject: [armedbear-cvs] r13171 - branches/0.24.x/abcl Message-ID: Author: mevenson Date: Sat Jan 22 05:17:41 2011 New Revision: 13171 Log: Merge: r13165-13166: Update README. Modified: branches/0.24.x/abcl/README Modified: branches/0.24.x/abcl/README ============================================================================== --- branches/0.24.x/abcl/README (original) +++ branches/0.24.x/abcl/README Sat Jan 22 05:17:41 2011 @@ -2,15 +2,15 @@ =================== Armed Bear Common Lisp is an implementation of ANSI Common Lisp that -runs in a Java virtual machine. It compiles its code to Java byte -code. +runs in a Java virtual machine. It compiles Lisp code directly to +Java byte code. LICENSE ======= Armed Bear Common Lisp is distributed under the GNU General Public -License with classpath exception (described below). +License with a classpath exception (see "Classpath Exception" below). A copy of GNU General Public License (GPL) is included in this distribution, in the file COPYING. @@ -20,6 +20,8 @@ conditions of the GNU General Public License cover the whole combination. +** Classpath Exception + As a special exception, the copyright holders of this software give you permission to link this software with independent modules to produce an executable, regardless of the license terms of these @@ -38,17 +40,17 @@ After you have downloaded a binary release archive unpack it into its own directory. To run ABCL directly from this directory, make sure -Java (version 1.5 or up) is in your shell's path. Then issue following -command +Java (version 1.5 or up) is in your shell's path. Then issue the +following command: cmd$ java -jar abcl.jar which should result in output like the following - Armed Bear Common Lisp 0.19.1 - Java 1.6.0_14 Sun Microsystems Inc. + Armed Bear Common Lisp 0.25.0 + Java 1.6.0_21 Sun Microsystems Inc. Java HotSpot(TM) Client VM - Low-level initialization completed in 0.9 seconds. + Low-level initialization completed in 0.3 seconds. Startup completed in 2.294 seconds. Type ":help" for a list of available commands. CL-USER(1): @@ -60,7 +62,7 @@ There are three ways to build ABCL from the source release with the preferred (and most tested way) is to being to use the Ant build tool: -* Use the Ant build tool for Java environments. +* Use the Ant build tool for Java environments. * Use the Netbeans 6.x IDE to open ABCL as a project. @@ -72,6 +74,11 @@ tested). Just the JRE isn't enough, as you need the Java compiler ('javac') to compile the Java source of the ABCL implementation. +Note that when deploying ABCL having JDK isn't a requirement for the +installation site, just the equivalent JRE, as ABCL compiles directly +to byte code, avoiding the need for the 'javac' compiler in deployment +environments. + Using Ant --------- @@ -84,10 +91,10 @@ Then simply executing - unix$ ant + unix$ ant or - cmd$ ant.bat + dos> ant.bat from the directory containing this README file will create an executable wrapper ('abcl' under UNIX, 'abcl.bat' under Windows). Use @@ -114,7 +121,7 @@ two methods, but it still may be of interest to those who absolutely don't want to know anything about Java. -First, copy the file 'customizations.lisp.in' to customization.lisp', +First, copy the file 'customizations.lisp.in' to 'customization.lisp', in the directory containing this README file, editing to suit your situation, paying attention to the comments in the file. The critical step is to have Lisp special variable '*JDK*' point to the root of the @@ -133,10 +140,9 @@ unix$ ./build-from-lisp.sh sbcl -After a successful build, you may use 'abcl.bat' on Windows or 'abcl' -on Unix to start ABCL. Note that this wrappers contain absolute -paths, so you'll need to edit them if you move things around after the -build. +After a successful build, you may use 'abcl' ('abcl.bat' on Windows) +to start ABCL. Note that this wrappers contain absolute paths, so +you'll need to edit them if you move things around after the build. If you're developing on ABCL, you may want to use @@ -150,14 +156,14 @@ This invokes javac separately for each .java file, which avoids running into limitations on command line length (but is a lot slower). - + ** Building from another Lisp by hand There is also an ASDF definition in 'abcl.asd' for the BUILD-ABCL which can be used to load the necessary Lisp definitions, after which CL-USER> (build-abcl:build-abcl :clean t :full t) - + will build ABCL. If ASDF isn't present, simply LOAD the 'customizations.lisp' and 'build-abcl.lisp' files to achieve the same effect as loading the ASDF definition. @@ -168,21 +174,15 @@ A lot of (renewed) energy has been spent to make ABCL a compliant and practically useable Common Lisp implementation. Because of this, -ABCL 0.19.1 now fails only 29 out of 21702 tests in the ANSI CL test -suite. Next to that, the fail count of the Maxima test suite has been -reduced to only 5 - rounding errors. - -ABCL's CLOS does not handle on-the-fly redefinition of classes -correctly. Quite a bit of energy has been spent in versions 0.16.0 and -0.17.0 to improve CLOS performance. There is no support for the long -form of DEFINE-METHOD-COMBINATION, and certain other required CLOS -features are also missing. Enough CLOS is there to run -ASDF2 and CL-PPCRE. +ABCL 0.25.0 now fails only 28 out of 21702 tests in the ANSI CL test +suite. In addition, Maxima's test suite runs without failures now +and ABCL's CLOS complete, with the exception of the long form of +DEFINE-METHOD-COMBINATION - which is an ongoing effort. -There is no MOP worth mentioning. +The MOP implementation is incomplete. -Patches to address any of the issues mentioned above will be gladly -accepted. +Patches to address any of the issues mentioned above will +be gladly accepted. Please report problems to the development mailing list: @@ -192,4 +192,4 @@ On behalf of all ABCL development team and contributors, Erik Huelsmann -March 20, 2010 +January 20, 2011 From ehuelsmann at common-lisp.net Sat Jan 22 11:15:04 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 22 Jan 2011 06:15:04 -0500 Subject: [armedbear-cvs] r13172 - trunk/abcl Message-ID: Author: ehuelsmann Date: Sat Jan 22 06:15:03 2011 New Revision: 13172 Log: Set a release date on 0.24.0. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Sat Jan 22 06:15:03 2011 @@ -1,7 +1,7 @@ Version 0.24.0 ============== svn://common-lisp.net/project/armedbear/svn/tags/0.24.0/abcl -(unreleased) +(22 January 2011) Features -------- From ehuelsmann at common-lisp.net Sat Jan 22 11:15:52 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 22 Jan 2011 06:15:52 -0500 Subject: [armedbear-cvs] r13173 - branches/0.24.x/abcl Message-ID: Author: ehuelsmann Date: Sat Jan 22 06:15:51 2011 New Revision: 13173 Log: Backport CHANGES. Modified: branches/0.24.x/abcl/CHANGES Modified: branches/0.24.x/abcl/CHANGES ============================================================================== --- branches/0.24.x/abcl/CHANGES (original) +++ branches/0.24.x/abcl/CHANGES Sat Jan 22 06:15:51 2011 @@ -1,7 +1,7 @@ Version 0.24.0 ============== svn://common-lisp.net/project/armedbear/svn/tags/0.24.0/abcl -(unreleased) +(22 January 2011) Features -------- From ehuelsmann at common-lisp.net Sat Jan 22 11:17:54 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 22 Jan 2011 06:17:54 -0500 Subject: [armedbear-cvs] r13174 - in tags/0.24.0: . abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jan 22 06:17:53 2011 New Revision: 13174 Log: Tag 0.24.0. Added: tags/0.24.0/ - copied from r13173, /branches/0.24.x/ Modified: tags/0.24.0/abcl/src/org/armedbear/lisp/Version.java Modified: tags/0.24.0/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- /branches/0.24.x/abcl/src/org/armedbear/lisp/Version.java (original) +++ tags/0.24.0/abcl/src/org/armedbear/lisp/Version.java Sat Jan 22 06:17:53 2011 @@ -41,7 +41,7 @@ public static String getVersion() { - return "0.24.0-dev"; + return "0.24.0"; } public static void main(String args[]) { From ehuelsmann at common-lisp.net Sat Jan 22 11:18:48 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 22 Jan 2011 06:18:48 -0500 Subject: [armedbear-cvs] r13175 - branches/0.24.x/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jan 22 06:18:47 2011 New Revision: 13175 Log: Increase branch version number. Modified: branches/0.24.x/abcl/src/org/armedbear/lisp/Version.java Modified: branches/0.24.x/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- branches/0.24.x/abcl/src/org/armedbear/lisp/Version.java (original) +++ branches/0.24.x/abcl/src/org/armedbear/lisp/Version.java Sat Jan 22 06:18:47 2011 @@ -41,7 +41,7 @@ public static String getVersion() { - return "0.24.0-dev"; + return "0.24.1-dev"; } public static void main(String args[]) { From ehuelsmann at common-lisp.net Sat Jan 22 17:44:51 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 22 Jan 2011 12:44:51 -0500 Subject: [armedbear-cvs] r13176 - in public_html: . releases/0.24.0 Message-ID: Author: ehuelsmann Date: Sat Jan 22 12:44:44 2011 New Revision: 13176 Log: Publish 0.24.0. Added: public_html/release-notes-0.24.shtml (contents, props changed) public_html/releases/0.24.0/ public_html/releases/0.24.0/abcl-bin-0.24.0.tar.gz (contents, props changed) public_html/releases/0.24.0/abcl-bin-0.24.0.tar.gz.asc public_html/releases/0.24.0/abcl-bin-0.24.0.zip (contents, props changed) public_html/releases/0.24.0/abcl-bin-0.24.0.zip.asc public_html/releases/0.24.0/abcl-src-0.24.0.tar.gz (contents, props changed) public_html/releases/0.24.0/abcl-src-0.24.0.tar.gz.asc public_html/releases/0.24.0/abcl-src-0.24.0.zip (contents, props changed) public_html/releases/0.24.0/abcl-src-0.24.0.zip.asc Modified: public_html/index.shtml public_html/left-menu Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Sat Jan 22 12:44:44 2011 @@ -61,24 +61,24 @@ Binary - abcl-bin-0.23.1.tar.gz - (pgp) + abcl-bin-0.24.0.tar.gz + (pgp) - abcl-bin-0.23.1.zip - (pgp) + abcl-bin-0.24.0.zip + (pgp) Source - abcl-src-0.23.1.tar.gz - (pgp) + abcl-src-0.24.0.tar.gz + (pgp) - abcl-src-0.23.1.zip - (pgp) + abcl-src-0.24.0.zip + (pgp) Modified: public_html/left-menu ============================================================================== --- public_html/left-menu (original) +++ public_html/left-menu Sat Jan 22 12:44:44 2011 @@ -1,7 +1,7 @@
      Project page
      Testimonials
      -Release notes
      +Release notes
      Paid support
      Added: public_html/release-notes-0.24.shtml ============================================================================== --- (empty file) +++ public_html/release-notes-0.24.shtml Sat Jan 22 12:44:44 2011 @@ -0,0 +1,72 @@ + + + + + ABCL - Release notes v0.24 + + + + + +
      +

      ABCL - Release notes for version 0.24

      +
      + + + +
      + +

      Most notable changes in ABCL 0.24

      + + +

      Release notes for older releases.

      + +
      +
      Fixed an issue causing FASLs to be able to contain only a limited + number of functions. +
      +
      As part of an attempt to increase ABCL's boot performance, + the ability for a FASL to contain an arbitrary number of functions was + broken. The old behaviour is now restored. There was no notable difference + in startup times. +
      +
      Improved support for embedding: ABCL no longer + contains calls to System.exit(). +
      +
      Instead of calling System.exit(), ABCL now throws one of two Errors. + When the EXT:EXIT or EXT:QUIT functions are called, it throws + org.armedbear.lisp.ProcessingTerminated. If an unrecoverable integrity + error is encountered, it throws an org.armedbear.lisp.IntegrityError +
      +
      Updated ASDF2
      +
      ASDF2 has been updated to its latest version 2.012
      +
      Experimental support for the long form of DEFINE-METHOD-COMBINATION
      +
      Support for the long form of DEFINE-METHOD-COMBINATION has been added, + however, this support is derived from Sacla and XCL, which probably means + that the code hasn't been excercised all that much and does contain + bugs. You're strongly urged to help debug and define test-cases in order + to fix any issues in the code.
      +
      Extended class file writer: now with support for writing interfaces +
      +
      The new class file writer from the last release was specifically + targetted at generating class-defining class files. It has now been + extended to allow generating interface files. +
      + +
      + + + + +
      +
      +

      Back to Common-lisp.net.

      + +
      + Valid XHTML 1.0 Strict +
      +
      $Id$
      +
      + + Added: public_html/releases/0.24.0/abcl-bin-0.24.0.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/0.24.0/abcl-bin-0.24.0.tar.gz.asc ============================================================================== --- (empty file) +++ public_html/releases/0.24.0/abcl-bin-0.24.0.tar.gz.asc Sat Jan 22 12:44:44 2011 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAk06yGAACgkQi5O0Epaz9TmFTgCfVzf46EAeY8JabtusPHAHf1ly +lAMAnjyx3LDw5Yu3C3tdp5XGFCCxBpUf +=ZbPM +-----END PGP SIGNATURE----- Added: public_html/releases/0.24.0/abcl-bin-0.24.0.zip ============================================================================== Binary file. No diff available. Added: public_html/releases/0.24.0/abcl-bin-0.24.0.zip.asc ============================================================================== --- (empty file) +++ public_html/releases/0.24.0/abcl-bin-0.24.0.zip.asc Sat Jan 22 12:44:44 2011 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAk06yFYACgkQi5O0Epaz9TkafgCfe2WZyFGumpdEMhYQeFp9AnTw +HmUAn1tiIoukDyKZZHuL1NiMraUu4rzt +=1ZbX +-----END PGP SIGNATURE----- Added: public_html/releases/0.24.0/abcl-src-0.24.0.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/0.24.0/abcl-src-0.24.0.tar.gz.asc ============================================================================== --- (empty file) +++ public_html/releases/0.24.0/abcl-src-0.24.0.tar.gz.asc Sat Jan 22 12:44:44 2011 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAk06yE0ACgkQi5O0Epaz9TmfkwCeLmWHRhEANu6YLPChoXOht817 +TGoAnigtr4LQ0Mf+KCR56NVH7+bxvVBY +=te+p +-----END PGP SIGNATURE----- Added: public_html/releases/0.24.0/abcl-src-0.24.0.zip ============================================================================== Binary file. No diff available. Added: public_html/releases/0.24.0/abcl-src-0.24.0.zip.asc ============================================================================== --- (empty file) +++ public_html/releases/0.24.0/abcl-src-0.24.0.zip.asc Sat Jan 22 12:44:44 2011 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAk06yEYACgkQi5O0Epaz9TmVNgCcDEO/JL8gQMuJO12hPYpuwWhB +AmoAniJ0KAldHA5sA0SWVUE01vhFTV2a +=Z2no +-----END PGP SIGNATURE----- From ehuelsmann at common-lisp.net Sat Jan 22 20:03:01 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 22 Jan 2011 15:03:01 -0500 Subject: [armedbear-cvs] r13177 - public_html Message-ID: Author: ehuelsmann Date: Sat Jan 22 15:03:00 2011 New Revision: 13177 Log: Correct release notes for 0.24. Modified: public_html/release-notes-0.24.shtml Modified: public_html/release-notes-0.24.shtml ============================================================================== --- public_html/release-notes-0.24.shtml (original) +++ public_html/release-notes-0.24.shtml Sat Jan 22 15:03:00 2011 @@ -41,12 +41,6 @@
      Updated ASDF2
      ASDF2 has been updated to its latest version 2.012
      -
      Experimental support for the long form of DEFINE-METHOD-COMBINATION
      -
      Support for the long form of DEFINE-METHOD-COMBINATION has been added, - however, this support is derived from Sacla and XCL, which probably means - that the code hasn't been excercised all that much and does contain - bugs. You're strongly urged to help debug and define test-cases in order - to fix any issues in the code.
      Extended class file writer: now with support for writing interfaces
      The new class file writer from the last release was specifically From ehuelsmann at common-lisp.net Sat Jan 22 22:56:33 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 22 Jan 2011 17:56:33 -0500 Subject: [armedbear-cvs] r13178 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jan 22 17:55:38 2011 New Revision: 13178 Log: Fix problem found by Blake McBride while running SCONE. Note: the problem was that SCONE tries to bind a symbol named 1s2f, which was interpreted as a number by ABCL. Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java 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 Jan 22 17:55:38 2011 @@ -1329,7 +1329,6 @@ private static final LispObject makeFloat(final String token, final int length) - { if (length == 0) return null; @@ -1377,6 +1376,13 @@ return null; // Append rest of token. sb.append(token.substring(i)); + c = sb.charAt(sb.length()-1); + if (! ('0' <= c && c <= '9')) + // we need to check that the last item is a number: + // the Double.parseDouble routine accepts numbers ending in 'D' + // like 1e2d. The same is true for Float.parseFloat and the 'F' + // character. However, these are not valid Lisp floats. + return null; try { if (marker == 0) { LispObject format = Symbol.READ_DEFAULT_FLOAT_FORMAT.symbolValue(); From ehuelsmann at common-lisp.net Sun Jan 23 11:26:43 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 23 Jan 2011 06:26:43 -0500 Subject: [armedbear-cvs] r13179 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 23 06:26:36 2011 New Revision: 13179 Log: Add comment on how to prevent a specialization of Condition.initialize(). Modified: trunk/abcl/src/org/armedbear/lisp/PackageError.java Modified: trunk/abcl/src/org/armedbear/lisp/PackageError.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/PackageError.java (original) +++ trunk/abcl/src/org/armedbear/lisp/PackageError.java Sun Jan 23 06:26:36 2011 @@ -55,6 +55,8 @@ // name, because it may omit an (important) package name part. // Two problems: (1) symbols can be contained in sublists // (2) symbols may not be printed, but used otherwise. + // ### FIXME: why special-case that here: binding *PRINT-ESCAPE* to T + // will do exactly this, if the reader requests it. for (LispObject arg = initArgs.cdr(); arg != NIL; arg = arg.cdr()) { if (arg.car() instanceof Symbol) arg.setCar(new SimpleString(((Symbol)arg.car()).getQualifiedName())); From ehuelsmann at common-lisp.net Sun Jan 23 11:26:48 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 23 Jan 2011 06:26:48 -0500 Subject: [armedbear-cvs] r13180 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 23 06:26:46 2011 New Revision: 13180 Log: Remove redundant method. Modified: trunk/abcl/src/org/armedbear/lisp/SeriousCondition.java Modified: trunk/abcl/src/org/armedbear/lisp/SeriousCondition.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SeriousCondition.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SeriousCondition.java Sun Jan 23 06:26:46 2011 @@ -51,12 +51,6 @@ super(initArgs); } - @Override - protected void initialize(LispObject initArgs) - { - super.initialize(initArgs); - } - public SeriousCondition(String message) { super(message); From ehuelsmann at common-lisp.net Sun Jan 23 20:08:53 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 23 Jan 2011 15:08:53 -0500 Subject: [armedbear-cvs] r13181 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 23 15:08:52 2011 New Revision: 13181 Log: Increase autoload verbosity: include FASLs too (not only Java classes). Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Sun Jan 23 15:08:52 2011 @@ -97,46 +97,59 @@ symbol.setSymbolFunction(new Autoload(symbol, null, "org.armedbear.lisp.".concat(className))); } - - public void load() - { + + + private static void effectiveLoad(String className, String fileName) { if (className != null) { - final LispThread thread = LispThread.currentThread(); - final SpecialBindingsMark mark = thread.markSpecialBindings(); - int loadDepth = Fixnum.getValue(_LOAD_DEPTH_.symbolValue()); - thread.bindSpecial(_LOAD_DEPTH_, Fixnum.getInstance(++loadDepth)); try { - if (_AUTOLOAD_VERBOSE_.symbolValue(thread) != NIL - || "Y".equals(System.getProperty("abcl.autoload.verbose"))) - { - final String prefix = Load.getLoadVerbosePrefix(loadDepth); - Stream out = getStandardOutput(); - out._writeString(prefix); - out._writeString(" Autoloading "); - out._writeString(className); - out._writeLine(" ..."); - out._finishOutput(); - long start = System.currentTimeMillis(); - Class.forName(className); - long elapsed = System.currentTimeMillis() - start; - out._writeString(prefix); - out._writeString(" Autoloaded "); - out._writeString(className); - out._writeString(" ("); - out._writeString(String.valueOf(((float)elapsed)/1000)); - out._writeLine(" seconds)"); - out._finishOutput(); - } else - Class.forName(className); + Class.forName(className); } catch (ClassNotFoundException e) { e.printStackTrace(); } - finally { - thread.resetSpecialBindings(mark); - } - } else - Load.loadSystemFile(getFileName(), true); + } else { + Load.loadSystemFile(fileName, true); + } + } + + private static void loadVerbose(int loadDepth, String className, + String fileName) { + final String prefix = Load.getLoadVerbosePrefix(loadDepth); + Stream out = getStandardOutput(); + out._writeString(prefix); + out._writeString(" Autoloading "); + out._writeString(className == null ? fileName : className); + out._writeLine(" ..."); + out._finishOutput(); + long start = System.currentTimeMillis(); + effectiveLoad(className, fileName); + long elapsed = System.currentTimeMillis() - start; + out._writeString(prefix); + out._writeString(" Autoloaded "); + out._writeString(className == null ? fileName : className); + out._writeString(" ("); + out._writeString(String.valueOf(((float)elapsed)/1000)); + out._writeLine(" seconds)"); + out._finishOutput(); + } + + public void load() + { + final LispThread thread = LispThread.currentThread(); + final SpecialBindingsMark mark = thread.markSpecialBindings(); + int loadDepth = Fixnum.getValue(_LOAD_DEPTH_.symbolValue()); + thread.bindSpecial(_LOAD_DEPTH_, Fixnum.getInstance(++loadDepth)); + try { + if (_AUTOLOAD_VERBOSE_.symbolValue(thread) != NIL + || "Y".equals(System.getProperty("abcl.autoload.verbose"))) + { + loadVerbose(loadDepth, className, getFileName()); + } else + effectiveLoad(className, getFileName()); + } + finally { + thread.resetSpecialBindings(mark); + } if (debug) { if (symbol != null) { if (symbol.getSymbolFunction() instanceof Autoload) { From ehuelsmann at common-lisp.net Mon Jan 24 20:50:28 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 24 Jan 2011 15:50:28 -0500 Subject: [armedbear-cvs] r13182 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jan 24 15:50:26 2011 New Revision: 13182 Log: Fix part of the error printing issues reported by Blake. Modified: trunk/abcl/src/org/armedbear/lisp/Condition.java 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 Mon Jan 24 15:50:26 2011 @@ -135,8 +135,7 @@ */ public String getMessage() { - LispObject formatControl = getFormatControl(); - return formatControl != UNBOUND_VALUE ? formatControl.writeToString() : null; + return null; } @Override From ehuelsmann at common-lisp.net Tue Jan 25 21:24:04 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 25 Jan 2011 16:24:04 -0500 Subject: [armedbear-cvs] r13183 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Jan 25 16:24:03 2011 New Revision: 13183 Log: Make sure we autoload FORMAT whenever we've booted far enough and the functions actually invoke simple-format. Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/autoloads.lisp trunk/abcl/src/org/armedbear/lisp/boot.lisp trunk/abcl/src/org/armedbear/lisp/format.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Tue Jan 25 16:24:03 2011 @@ -1738,11 +1738,7 @@ } }; - private static final Symbol _SIMPLE_FORMAT_FUNCTION_ = - internSpecial("*SIMPLE-FORMAT-FUNCTION*", PACKAGE_SYS, _FORMAT); - static void checkRedefinition(LispObject arg) - { final LispThread thread = LispThread.currentThread(); if (_WARN_ON_REDEFINITION_.symbolValue(thread) != NIL) { Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Tue Jan 25 16:24:03 2011 @@ -435,3 +435,11 @@ (sys::autoload-macro '(pprint-logical-block) "pprint") +(in-package "SYSTEM") + +;; This one must be last, or at least past print-object and clos: +;; we don't want FORMATs executed before we can load those to end us +;; in a debugger. This command replaces the earlier function binding +;; where simple-format calls sys::%format + +(autoload 'simple-format "format") \ No newline at end of file Modified: trunk/abcl/src/org/armedbear/lisp/boot.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/boot.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/boot.lisp Tue Jan 25 16:24:03 2011 @@ -121,7 +121,7 @@ (in-package #:system) (defun simple-format (destination control-string &rest args) - (apply *simple-format-function* destination control-string args)) + (apply #'format destination control-string args)) (export 'simple-format '#:system) 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 Tue Jan 25 16:24:03 2011 @@ -2866,7 +2866,7 @@ (t (args param))))) (apply (fdefinition symbol) stream (next-arg) colonp atsignp (args))))) -(setf sys::*simple-format-function* #'format) +(setf (symbol-function 'sys::simple-format) #'format) (provide 'format) From ehuelsmann at common-lisp.net Tue Jan 25 21:56:33 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 25 Jan 2011 16:56:33 -0500 Subject: [armedbear-cvs] r13184 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Jan 25 16:56:33 2011 New Revision: 13184 Log: Enhance error messages for improved user friendlyness, as requested by Blake. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Jan 25 16:56:33 2011 @@ -1472,7 +1472,7 @@ ~S." gf-keywords))))))) -(defun check-method-lambda-list (method-lambda-list gf-lambda-list) +(defun check-method-lambda-list (name method-lambda-list gf-lambda-list) (let* ((gf-restp (not (null (memq '&rest gf-lambda-list)))) (gf-plist (analyze-lambda-list gf-lambda-list)) (gf-keysp (getf gf-plist :keysp)) @@ -1484,24 +1484,34 @@ (method-allow-other-keys-p (getf method-plist :allow-other-keys))) (unless (= (length (getf gf-plist :required-args)) (length (getf method-plist :required-args))) - (error "The method has the wrong number of required arguments for the generic function.")) + (error "The method-lambda-list ~S ~ + has the wrong number of required arguments ~ + for the generic function ~S." method-lambda-list name)) (unless (= (length (getf gf-plist :optional-args)) (length (getf method-plist :optional-args))) - (error "The method has the wrong number of optional arguments for the generic function.")) + (error "The method-lambda-list ~S ~ + has the wrong number of optional arguments ~ + for the generic function ~S." method-lambda-list name)) (unless (eq (or gf-restp gf-keysp) (or method-restp method-keysp)) - (error "The method and the generic function differ in whether they accept &REST or &KEY arguments.")) + (error "The method-lambda-list ~S ~ + and the generic function ~S ~ + differ in whether they accept &REST or &KEY arguments." + method-lambda-list name)) (when (consp gf-keywords) (unless (or (and method-restp (not method-keysp)) method-allow-other-keys-p (every (lambda (k) (memq k method-keywords)) gf-keywords)) - (error "The method does not accept all of the keyword arguments defined for the generic function."))))) + (error "The method-lambda-list ~S does not accept ~ + all of the keyword arguments defined for the ~ + generic function." method-lambda-list name))))) (declaim (ftype (function * method) ensure-method)) (defun ensure-method (name &rest all-keys) (let ((method-lambda-list (getf all-keys :lambda-list)) (gf (find-generic-function name nil))) (if gf - (check-method-lambda-list method-lambda-list (generic-function-lambda-list gf)) + (check-method-lambda-list name method-lambda-list + (generic-function-lambda-list gf)) (setf gf (ensure-generic-function name :lambda-list method-lambda-list))) (let ((method (if (eq (generic-function-method-class gf) +the-standard-method-class+) @@ -2139,8 +2149,10 @@ (let ((method-lambda-list '(object)) (gf (find-generic-function function-name nil))) (if gf - (check-method-lambda-list method-lambda-list (generic-function-lambda-list gf)) - (setf gf (ensure-generic-function function-name :lambda-list method-lambda-list))) + (check-method-lambda-list function-name + method-lambda-list + (generic-function-lambda-list gf)) + (setf gf (ensure-generic-function function-name :lambda-list method-lambda-list))) (let ((method (make-instance-standard-reader-method gf :lambda-list '(object) @@ -2959,15 +2971,17 @@ &optional errorp)) (defmethod find-method ((generic-function standard-generic-function) - qualifiers specializers &optional (errorp t)) + qualifiers specializers &optional (errorp t)) (%find-method generic-function qualifiers specializers errorp)) (defgeneric add-method (generic-function method)) -(defmethod add-method ((generic-function standard-generic-function) (method method)) +(defmethod add-method ((generic-function standard-generic-function) + (method method)) (let ((method-lambda-list (method-lambda-list method)) (gf-lambda-list (generic-function-lambda-list generic-function))) - (check-method-lambda-list method-lambda-list gf-lambda-list)) + (check-method-lambda-list (%generic-function-name generic-function) + method-lambda-list gf-lambda-list)) (%add-method generic-function method)) (defgeneric remove-method (generic-function method)) From ehuelsmann at common-lisp.net Wed Jan 26 08:39:58 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 26 Jan 2011 03:39:58 -0500 Subject: [armedbear-cvs] r13185 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Jan 26 03:39:54 2011 New Revision: 13185 Log: Fix #119: Incorrect dynamic environment for evaluation of :CLASS allocation slot initforms. 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 Jan 26 03:39:54 2011 @@ -165,7 +165,7 @@ (readers ()) (writers ()) (other-options ()) - (non-std-options ())) + (non-std-options ())) (do ((olist (cdr spec) (cddr olist))) ((null olist)) (case (car olist) @@ -174,9 +174,8 @@ (error 'program-error "duplicate slot option :INITFORM for slot named ~S" name)) - (setq initfunction - `(function (lambda () ,(cadr olist)))) - (setq initform `',(cadr olist))) + (setq initfunction t) + (setq initform (cadr olist))) (:initarg (push-on-end (cadr olist) initargs)) (:allocation @@ -210,13 +209,21 @@ (push-on-end (cadr olist) readers) (push-on-end `(setf ,(cadr olist)) writers)) (t - (push-on-end `(quote ,(car olist)) non-std-options) + (push-on-end `(quote ,(car olist)) non-std-options) (push-on-end (cadr olist) non-std-options)))) `(list :name ',name ,@(when initfunction - `(:initform ,initform - :initfunction ,initfunction)) + `(:initform ',initform + :initfunction ,(if (eq allocation :class) + ;; CLHS specifies the initform for a + ;; class allocation level slot needs + ;; to be evaluated in the dynamic + ;; extent of the DEFCLASS form + (let ((var (gensym))) + `(let ((,var ,initform)) + (lambda () ,var))) + `(lambda () ,initform)))) ,@(when initargs `(:initargs ',initargs)) ,@(when readers `(:readers ',readers)) ,@(when writers `(:writers ',writers)) @@ -1312,10 +1319,10 @@ (eq (car object) 'quote)) (setf object (cadr object))) (intern-eql-specializer object))) - ((and (consp specializer) + ((and (consp specializer) (eq (car specializer) 'java:jclass)) (let ((jclass (eval specializer))) - (java::ensure-java-class jclass))) + (java::ensure-java-class jclass))) (t (error "Unknown specializer: ~S" specializer)))) From mevenson at common-lisp.net Wed Jan 26 10:05:48 2011 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 26 Jan 2011 05:05:48 -0500 Subject: [armedbear-cvs] r13186 - trunk/abcl/examples/java-interface Message-ID: Author: mevenson Date: Wed Jan 26 05:05:44 2011 New Revision: 13186 Log: Add a slightly simpler example of implemeting a Java interface in Lisp. TODO Needs further documentation. Added: trunk/abcl/examples/java-interface/BankAccount.java trunk/abcl/examples/java-interface/BankExampleMain.java trunk/abcl/examples/java-interface/bank-account.lisp trunk/abcl/examples/java-interface/build.xml Modified: trunk/abcl/examples/java-interface/README Added: trunk/abcl/examples/java-interface/BankAccount.java ============================================================================== --- (empty file) +++ trunk/abcl/examples/java-interface/BankAccount.java Wed Jan 26 05:05:44 2011 @@ -0,0 +1,5 @@ +public interface BankAccount { + public int getBalance(); + public void deposit(int amount); + public void withdraw(int amount); +} \ No newline at end of file Added: trunk/abcl/examples/java-interface/BankExampleMain.java ============================================================================== --- (empty file) +++ trunk/abcl/examples/java-interface/BankExampleMain.java Wed Jan 26 05:05:44 2011 @@ -0,0 +1,23 @@ +import org.armedbear.lisp.Interpreter; +import org.armedbear.lisp.Symbol; +import org.armedbear.lisp.Packages; +import org.armedbear.lisp.JavaObject; +import org.armedbear.lisp.LispObject; + +public class BankExampleMain +{ + static public void main(String argv[]) { + Interpreter interpreter = Interpreter.createInstance(); + interpreter.eval("(load \"bank-account.lisp\")"); + org.armedbear.lisp.Package defaultPackage + = Packages.findPackage("CL-USER"); + Symbol bankAccountImplSymbol + = defaultPackage.findAccessibleSymbol("*BANK-ACCOUNT-IMPL*"); + LispObject value = bankAccountImplSymbol.symbolValue(); + Object object = ((JavaObject) value).getObject(); + BankAccount account = (BankAccount) object; + System.out.println("Initial balance: " + account.getBalance()); + account.withdraw(500); + System.out.println("After withdrawing 500: " + account.getBalance()); + } +} \ No newline at end of file Modified: trunk/abcl/examples/java-interface/README ============================================================================== --- trunk/abcl/examples/java-interface/README (original) +++ trunk/abcl/examples/java-interface/README Wed Jan 26 05:05:44 2011 @@ -3,7 +3,7 @@ To compile - cmd$ javac -cp ../../dist/abcl.jar Main.java + cmd$ javac -cp ../../dist/abcl.jar Main.java BankAccountMain.java where the "../../../dist/abcl.jar" represents the path to your abcl.jar file, which is built via the Ant based build. This path @@ -27,3 +27,4 @@ where "Main" is the initial class to run in your Java program. + Added: trunk/abcl/examples/java-interface/bank-account.lisp ============================================================================== --- (empty file) +++ trunk/abcl/examples/java-interface/bank-account.lisp Wed Jan 26 05:05:44 2011 @@ -0,0 +1,19 @@ +(defparameter *bank-account-impl* + (let ((balance 1000)) + (jinterface-implementation + "BankAccount" + + "getBalance" + (lambda () + balance) + "deposit" + (lambda (amount) + (let ((amount (jobject-lisp-value amount))) + (setf balance (+ balance amount)))) + "withdraw" + (lambda (amount) + (let ((amount (jobject-lisp-value amount))) + (setf balance (- balance amount))))))) + +(defun get-bank-account-impl () + *bank-account-impl*) Added: trunk/abcl/examples/java-interface/build.xml ============================================================================== --- (empty file) +++ trunk/abcl/examples/java-interface/build.xml Wed Jan 26 05:05:44 2011 @@ -0,0 +1,17 @@ + + + + + + + + + \ No newline at end of file From ehuelsmann at common-lisp.net Thu Jan 27 21:08:56 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 27 Jan 2011 16:08:56 -0500 Subject: [armedbear-cvs] r13187 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jan 27 16:08:52 2011 New Revision: 13187 Log: Fix #125: FASL reader should not convert symbol case [Qi FASL loading issues]. Modified: trunk/abcl/src/org/armedbear/lisp/FaslReadtable.java Modified: trunk/abcl/src/org/armedbear/lisp/FaslReadtable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FaslReadtable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/FaslReadtable.java Thu Jan 27 16:08:52 2011 @@ -103,7 +103,12 @@ dtfunctions['?'] = FaslReader.FASL_SHARP_QUESTION_MARK; dispatchTables.constants['#'] = dt; - readtableCase = Keyword.UPCASE; + readtableCase = Keyword.PRESERVE; + // after all, all symbols will have been uppercased by the reader, + // if applicable, when reading the source file; so, any lower-case + // symbols are really meant to be lower case, even if printed without + // pipe characters, which may happen if the READTABLE-CASE of the + // current readtable is :PRESERVE when printing the symbols } private static final FaslReadtable instance = new FaslReadtable(); From ehuelsmann at common-lisp.net Thu Jan 27 22:48:11 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 27 Jan 2011 17:48:11 -0500 Subject: [armedbear-cvs] r13188 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jan 27 17:48:10 2011 New Revision: 13188 Log: Fix DEFSTRUCT trying to generate accessors named NIL. Note: Especially in case of LIST type structures, DEFSTRUCT generates fake slot definitions with name NIL. Modified: trunk/abcl/src/org/armedbear/lisp/defstruct.lisp Modified: trunk/abcl/src/org/armedbear/lisp/defstruct.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/defstruct.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/defstruct.lisp Thu Jan 27 17:48:10 2011 @@ -375,10 +375,11 @@ (let ((result ())) (dolist (slot *dd-slots*) (let ((accessor-name (dsd-reader slot))) - (unless (assoc accessor-name *dd-inherited-accessors*) - (setf result (nconc result (define-reader slot))) - (unless (dsd-read-only slot) - (setf result (nconc result (define-writer slot))))))) + (unless (null accessor-name) + (unless (assoc accessor-name *dd-inherited-accessors*) + (setf result (nconc result (define-reader slot))) + (unless (dsd-read-only slot) + (setf result (nconc result (define-writer slot)))))))) result)) (defun define-copier () From ehuelsmann at common-lisp.net Fri Jan 28 23:17:41 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 28 Jan 2011 18:17:41 -0500 Subject: [armedbear-cvs] r13189 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Jan 28 18:17:39 2011 New Revision: 13189 Log: Fix MACROEXPAND-ALL autoloader which should be loaded from 'format.lisp'. Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Fri Jan 28 18:17:39 2011 @@ -366,7 +366,7 @@ (export 'describe-compiler-policy) (autoload 'describe-compiler-policy) (export 'macroexpand-all) -(autoload 'macroexpand-all) +(autoload 'macroexpand-all "format") (export '*gui-backend*) (export 'init-gui) From ehuelsmann at common-lisp.net Sun Jan 30 13:17:51 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 30 Jan 2011 08:17:51 -0500 Subject: [armedbear-cvs] r13190 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 30 08:17:50 2011 New Revision: 13190 Log: Detect loops in autoloads and requires (and remove some trailing whitespace). Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/require.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 Sun Jan 30 08:17:50 2011 @@ -45,6 +45,12 @@ private final Symbol symbol; + private final static Symbol AUTOLOADS_IN_PROGRESS + = PACKAGE_SYS.addInternalSymbol("*AUTOLOADS-IN-PROGRESS*"); + { + AUTOLOADS_IN_PROGRESS.setSymbolValue(NIL); + } + protected Autoload(Symbol symbol) { super(); @@ -133,12 +139,34 @@ out._finishOutput(); } + private void detectCircularity(LispThread thread) { + SimpleString val = new SimpleString((getFileName() == null) + ? className : getFileName()); + LispObject autoloads = AUTOLOADS_IN_PROGRESS.symbolValue(thread); + LispObject list = autoloads; + while (list != NIL) { + if (val.equal(list.car())) + Lisp.error(new SimpleString("Autoloading circularity detected while resolving " + + symbol.getQualifiedName() + "; autoloads in " + + "progress: " + autoloads.writeToString())); + + list = list.cdr(); + } + + return; + } + public void load() { final LispThread thread = LispThread.currentThread(); + + detectCircularity(thread); + final SpecialBindingsMark mark = thread.markSpecialBindings(); int loadDepth = Fixnum.getValue(_LOAD_DEPTH_.symbolValue()); thread.bindSpecial(_LOAD_DEPTH_, Fixnum.getInstance(++loadDepth)); + thread.pushSpecial(AUTOLOADS_IN_PROGRESS, + new SimpleString((getFileName() == null) ? className : getFileName())); try { if (_AUTOLOAD_VERBOSE_.symbolValue(thread) != NIL || "Y".equals(System.getProperty("abcl.autoload.verbose"))) 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 Sun Jan 30 08:17:50 2011 @@ -36,23 +36,30 @@ (pushnew (string module-name) *modules* :test #'string=) t) -(defun module-provide-system (module) +(defun module-provide-system (module) (let ((*readtable* (copy-readtable nil))) - (handler-case + (handler-case (load-system-file (string-downcase (string module))) - (t (e) + (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'~%" + (format *error-output* "Failed to require ~A because '~A'~%" module e)) nil)))) - + (defvar *module-provider-functions* nil) +(defvar *requires-in-progress* nil) (defun require (module-name &optional pathnames) (unless (member (string module-name) *modules* :test #'string=) - (let ((saved-modules (copy-list *modules*))) + (unless (member (string module-name) *requires-in-progress* + :test #'string=) + (error "Circularity detected while requiring ~A; ~ + nesting list: ~S." module-name *requires-in-progress*)) + (let ((saved-modules (copy-list *modules*)) + (*requires-in-progress* (cons (string module-name) + *requires-in-progress*))) (cond (pathnames (unless (listp pathnames) (setf pathnames (list pathnames))) (dolist (x pathnames) From ehuelsmann at common-lisp.net Sun Jan 30 13:20:31 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 30 Jan 2011 08:20:31 -0500 Subject: [armedbear-cvs] r13191 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 30 08:20:31 2011 New Revision: 13191 Log: Signal an error containing the name of the class, when the type of the CLASS-LAYOUT slot isn't what it is expected to be. Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java 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 Jan 30 08:20:31 2011 @@ -132,6 +132,18 @@ public Layout getClassLayout() { LispObject layout = getInstanceSlotValue(symLayout); + if (layout == UNBOUND_VALUE) + return null; + + if (! (layout instanceof Layout)) { + (new Error()).printStackTrace(); + LispThread.currentThread().printBacktrace(); + return (Layout)Lisp.error(Symbol.TYPE_ERROR, + new SimpleString("The value " + layout.writeToString() + + " is not of expected type " + Symbol.LAYOUT.writeToString() + + " in class " + this.writeToString() + ".")); + } + return (layout == UNBOUND_VALUE) ? null : (Layout)layout; } From ehuelsmann at common-lisp.net Sun Jan 30 13:35:35 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 30 Jan 2011 08:35:35 -0500 Subject: [armedbear-cvs] r13192 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 30 08:35:34 2011 New Revision: 13192 Log: Signal an error containing the name of the class, when the type of the CLASS-LAYOUT slot isn't what it is expected to be. Modified: trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java Modified: trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java Sun Jan 30 08:35:34 2011 @@ -49,8 +49,11 @@ if (arg instanceof StandardClass) return ((StandardClass)arg).allocateInstance(); if (arg.typep(StandardClass.STANDARD_CLASS) != NIL) { - Layout layout = (Layout)Symbol.CLASS_LAYOUT.execute(arg); - return new StandardObject(layout); + LispObject l = Symbol.CLASS_LAYOUT.execute(arg); + if (! (l instanceof Layout)) + return error(new ProgramError("Invalid standard class layout for: " + arg.writeToString())); + + return new StandardObject((Layout)l); } return type_error(arg, Symbol.STANDARD_CLASS); } From ehuelsmann at common-lisp.net Sun Jan 30 18:55:49 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 30 Jan 2011 13:55:49 -0500 Subject: [armedbear-cvs] r13193 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 30 13:55:48 2011 New Revision: 13193 Log: Revert r13190: Detect loops in autoloads and requires. Note: This commit broke trunk; reverting restores it. Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/require.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 Sun Jan 30 13:55:48 2011 @@ -45,12 +45,6 @@ private final Symbol symbol; - private final static Symbol AUTOLOADS_IN_PROGRESS - = PACKAGE_SYS.addInternalSymbol("*AUTOLOADS-IN-PROGRESS*"); - { - AUTOLOADS_IN_PROGRESS.setSymbolValue(NIL); - } - protected Autoload(Symbol symbol) { super(); @@ -139,34 +133,12 @@ out._finishOutput(); } - private void detectCircularity(LispThread thread) { - SimpleString val = new SimpleString((getFileName() == null) - ? className : getFileName()); - LispObject autoloads = AUTOLOADS_IN_PROGRESS.symbolValue(thread); - LispObject list = autoloads; - while (list != NIL) { - if (val.equal(list.car())) - Lisp.error(new SimpleString("Autoloading circularity detected while resolving " - + symbol.getQualifiedName() + "; autoloads in " - + "progress: " + autoloads.writeToString())); - - list = list.cdr(); - } - - return; - } - public void load() { final LispThread thread = LispThread.currentThread(); - - detectCircularity(thread); - final SpecialBindingsMark mark = thread.markSpecialBindings(); int loadDepth = Fixnum.getValue(_LOAD_DEPTH_.symbolValue()); thread.bindSpecial(_LOAD_DEPTH_, Fixnum.getInstance(++loadDepth)); - thread.pushSpecial(AUTOLOADS_IN_PROGRESS, - new SimpleString((getFileName() == null) ? className : getFileName())); try { if (_AUTOLOAD_VERBOSE_.symbolValue(thread) != NIL || "Y".equals(System.getProperty("abcl.autoload.verbose"))) 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 Sun Jan 30 13:55:48 2011 @@ -36,30 +36,23 @@ (pushnew (string module-name) *modules* :test #'string=) t) -(defun module-provide-system (module) +(defun module-provide-system (module) (let ((*readtable* (copy-readtable nil))) - (handler-case + (handler-case (load-system-file (string-downcase (string module))) - (t (e) + (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'~%" + (format *error-output* "Failed to require ~A because '~A'~%" module e)) nil)))) - + (defvar *module-provider-functions* nil) -(defvar *requires-in-progress* nil) (defun require (module-name &optional pathnames) (unless (member (string module-name) *modules* :test #'string=) - (unless (member (string module-name) *requires-in-progress* - :test #'string=) - (error "Circularity detected while requiring ~A; ~ - nesting list: ~S." module-name *requires-in-progress*)) - (let ((saved-modules (copy-list *modules*)) - (*requires-in-progress* (cons (string module-name) - *requires-in-progress*))) + (let ((saved-modules (copy-list *modules*))) (cond (pathnames (unless (listp pathnames) (setf pathnames (list pathnames))) (dolist (x pathnames) From ehuelsmann at common-lisp.net Sun Jan 30 20:50:28 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 30 Jan 2011 15:50:28 -0500 Subject: [armedbear-cvs] r13194 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 30 15:50:27 2011 New Revision: 13194 Log: As a convenience-method: let BUILT-IN-CLASSes report themselves as FINALIZED-P. Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.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 Jan 30 15:50:27 2011 @@ -55,6 +55,12 @@ } @Override + public boolean isFinalized() + { + return true; + } + + @Override public LispObject typep(LispObject type) { if (type == Symbol.BUILT_IN_CLASS) From ehuelsmann at common-lisp.net Sun Jan 30 20:52:08 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 30 Jan 2011 15:52:08 -0500 Subject: [armedbear-cvs] r13195 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 30 15:52:07 2011 New Revision: 13195 Log: Finalize CLASS and STANDARD-OBJECT, just like most (all?) others in StandardClass. Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java 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 Jan 30 15:52:07 2011 @@ -694,6 +694,8 @@ // Condition classes. STANDARD_CLASS.finalizeClass(); + STANDARD_OBJECT.finalizeClass(); + CLASS.finalizeClass(); ARITHMETIC_ERROR.finalizeClass(); CELL_ERROR.finalizeClass(); COMPILER_ERROR.finalizeClass(); From ehuelsmann at common-lisp.net Sun Jan 30 21:19:46 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 30 Jan 2011 16:19:46 -0500 Subject: [armedbear-cvs] r13196 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 30 16:19:46 2011 New Revision: 13196 Log: Provide more context regarding the reason of autoloading. Note: This change *hugely* helps debugging. Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Sun Jan 30 16:19:46 2011 @@ -112,12 +112,12 @@ } } - private static void loadVerbose(int loadDepth, String className, + private static void loadVerbose(Symbol sym, int loadDepth, String className, String fileName) { final String prefix = Load.getLoadVerbosePrefix(loadDepth); Stream out = getStandardOutput(); out._writeString(prefix); - out._writeString(" Autoloading "); + out._writeString(sym.getQualifiedName() + " triggers autoloading of "); out._writeString(className == null ? fileName : className); out._writeLine(" ..."); out._finishOutput(); @@ -143,7 +143,7 @@ if (_AUTOLOAD_VERBOSE_.symbolValue(thread) != NIL || "Y".equals(System.getProperty("abcl.autoload.verbose"))) { - loadVerbose(loadDepth, className, getFileName()); + loadVerbose(symbol, loadDepth, className, getFileName()); } else effectiveLoad(className, getFileName()); } From mevenson at common-lisp.net Sun Jan 30 22:26:44 2011 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 30 Jan 2011 17:26:44 -0500 Subject: [armedbear-cvs] r13197 - in trunk/abcl: . src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun Jan 30 17:26:43 2011 New Revision: 13197 Log: Incorporate output of 'svnversion' into LISP-IMPLEMENTATION-VERSION. In the Ant-based build, if the executable 'svnversion' can be found on the PATH and the topmost '.svn' subdirectory exists, the output of 'svnversion' is appended to the value returned by LISP-IMPLEMENTATION-VERSION. The use of 'version.src' in 'abcl.properties' has been removed. TODO: the same functionality should be added to the Lisp-based build. TODO: test that this works on Windows. Modified: trunk/abcl/abcl.properties.in trunk/abcl/build.xml trunk/abcl/src/org/armedbear/lisp/Version.java Modified: trunk/abcl/abcl.properties.in ============================================================================== --- trunk/abcl/abcl.properties.in (original) +++ trunk/abcl/abcl.properties.in Sun Jan 30 17:26:43 2011 @@ -1,8 +1,5 @@ # $Id$ -# version.src contents show up in JAR Manifest in the Implementation-Source attribute -#version.src=[abcl svn] - # abcl.build.incremental attempts to perform incremental compilation #abcl.build.incremental=true Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Sun Jan 30 17:26:43 2011 @@ -85,6 +85,7 @@ + @@ -147,10 +148,6 @@ - - - Implementation-Source: ${version.src} - - + + + + + + + + + + + + + + + + + + + + + abcl.version.svn: ${abcl.version.svn} + + + + + + + - + + + + ABCL implementation version: ${abcl.implementation.version} + ${abcl.implementation.version} + + + + - ABCL version: ${abcl.version} - - + + + + + + @@ -324,11 +381,9 @@ + value="${abcl.implementation.version}"/> - Modified: trunk/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Version.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Version.java Sun Jan 30 17:26:43 2011 @@ -33,15 +33,34 @@ package org.armedbear.lisp; +import java.io.BufferedReader; +import java.io.InputStream; +import java.io.InputStreamReader; + public final class Version { - private Version() - { + private Version() {} + + static final String baseVersion = "0.25.0-dev"; + + static void init() { + try { + InputStream input = Version.class.getResourceAsStream("version"); + BufferedReader reader = new BufferedReader(new InputStreamReader(input)); + String v = reader.readLine().trim(); + version = v; + } catch (Throwable t) { + version = baseVersion; + } } - - public static String getVersion() + + static String version = ""; + public synchronized static String getVersion() { - return "0.25.0-dev"; + if ("".equals(version)) { + init(); + } + return version; } public static void main(String args[]) { From ehuelsmann at common-lisp.net Sun Jan 30 23:35:36 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 30 Jan 2011 18:35:36 -0500 Subject: [armedbear-cvs] r13198 - trunk/abcl Message-ID: Author: ehuelsmann Date: Sun Jan 30 18:35:36 2011 New Revision: 13198 Log: Update r13197 for Windows. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Sun Jan 30 18:35:36 2011 @@ -271,19 +271,41 @@ - + + + + + + - + + + + + + + + failifexecutionfails="false" + searchpath="true" /> Author: mevenson Date: Mon Jan 31 02:25:12 2011 New Revision: 13199 Log: Fix ad infinitum appending of 'svnversion' results in incremental builds. The 'version' file is now removed during each invocation of 'abcl.stamp.version' which adds a bit of time to each build, but at least implement the correct semantics (i.e. always produce an accurate svnversion result). An optimization might be to conditionally compare the contents of 'version' with the results of running a fresh 'svnversion', but to do this with Ant's tiny little insect brain requires more effort than this mammal deems wise to exert. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Mon Jan 31 02:25:12 2011 @@ -298,8 +298,6 @@ searchpath="true" /> - - + + + + + depends="abcl.clean.version,abcl.version.src,abcl.stamp.version.1,abcl.stamp.version.2"> ABCL implementation version: ${abcl.implementation.version} ${abcl.implementation.version} From ehuelsmann at common-lisp.net Mon Jan 31 21:18:10 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 31 Jan 2011 16:18:10 -0500 Subject: [armedbear-cvs] r13200 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jan 31 16:17:21 2011 New Revision: 13200 Log: Atomically swap generic functions into place of temporary DEFUNs for all standard-class slot accessors. Note: This addresses the recursive requirement to be able to allocate objects and classes while changing the functions used to create them. 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 Jan 31 16:17:21 2011 @@ -2198,16 +2198,21 @@ (autocompile fast-function)) ))) -(defmacro redefine-class-forwarder (name slot &optional alternative-name) +(defmacro redefine-class-forwarder (name slot) + "Define a generic function on a temporary symbol as an accessor +for the slot `slot'. Then, when definition is complete (including +allocation of methods), swap the definition in place. + +Without this approach, we can't depend the old forwarders to be +in place, while we still need them to " (let* (($name (if (consp name) (cadr name) name)) (%name (intern (concatenate 'string "%" (if (consp name) (symbol-name 'set-) "") (symbol-name $name)) - (find-package "SYS")))) - (unless alternative-name - (setf alternative-name name)) + (find-package "SYS"))) + (alternative-name (gensym))) (if (consp name) `(progn ;; setter (defgeneric ,alternative-name (new-value class)) @@ -2219,10 +2224,9 @@ (,%name new-value class)) (defmethod ,alternative-name (new-value (class standard-class)) (setf (slot-value class ',slot) new-value)) - ,@(unless (eq name alternative-name) - `((setf (get ',$name 'SETF-FUNCTION) - (symbol-function ',alternative-name)))) - ) + (let ((gf (symbol-function ',alternative-name))) + (setf (get ',$name 'SETF-FUNCTION) gf) + (%set-generic-function-name gf ',name))) `(progn ;; getter (defgeneric ,alternative-name (class)) (defmethod ,alternative-name ((class built-in-class)) @@ -2233,10 +2237,9 @@ (,%name class)) (defmethod ,alternative-name ((class standard-class)) (slot-value class ',slot)) - ,@(unless (eq name alternative-name) - `((setf (symbol-function ',$name) - (symbol-function ',alternative-name)))) - ) ))) + (let ((gf (symbol-function ',alternative-name))) + (setf (symbol-function ',$name) gf) + (%set-generic-function-name gf ',name)))))) (redefine-class-forwarder class-name name) (redefine-class-forwarder (setf class-name) name) @@ -2250,8 +2253,8 @@ (redefine-class-forwarder (setf class-direct-superclasses) direct-superclasses) (redefine-class-forwarder class-direct-subclasses direct-subclasses) (redefine-class-forwarder (setf class-direct-subclasses) direct-subclasses) -(redefine-class-forwarder class-direct-methods direct-methods !class-direct-methods) -(redefine-class-forwarder (setf class-direct-methods) direct-methods !!class-direct-methods) +(redefine-class-forwarder class-direct-methods direct-methods) +(redefine-class-forwarder (setf class-direct-methods) direct-methods) (redefine-class-forwarder class-precedence-list precedence-list) (redefine-class-forwarder (setf class-precedence-list) precedence-list) (redefine-class-forwarder class-finalized-p finalized-p) From ehuelsmann at common-lisp.net Mon Jan 31 21:45:43 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 31 Jan 2011 16:45:43 -0500 Subject: [armedbear-cvs] r13201 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jan 31 16:45:41 2011 New Revision: 13201 Log: Rename STD-ALLOCATE-INSTANCE to %STD-ALLOCATE-INSTANCE, creating STD-ALLOCATE-INSTANCE which is closer to the one specified by AMOP. Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java trunk/abcl/src/org/armedbear/lisp/clos.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 Mon Jan 31 16:45:41 2011 @@ -687,7 +687,7 @@ autoload(PACKAGE_SYS, "set-slot-definition-writers", "SlotDefinition", true); 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, "%std-allocate-instance", "StandardObjectFunctions", true); autoload(PACKAGE_SYS, "unzip", "unzip", true); autoload(PACKAGE_SYS, "zip", "zip", true); Modified: trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java Mon Jan 31 16:45:41 2011 @@ -37,9 +37,9 @@ public class StandardObjectFunctions { - // ### std-allocate-instance class => instance - private static final Primitive STD_ALLOCATE_INSTANCE = - new Primitive("std-allocate-instance", PACKAGE_SYS, true, "class") + // ### %std-allocate-instance class => instance + private static final Primitive _STD_ALLOCATE_INSTANCE = + new Primitive("%std-allocate-instance", PACKAGE_SYS, true, "class") { @Override public LispObject execute(LispObject arg) 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 Jan 31 16:45:41 2011 @@ -623,6 +623,13 @@ (defun instance-slot-p (slot) (eq (slot-definition-allocation slot) :instance)) +(defun std-allocate-instance (class) + ;; AMOP says ALLOCATE-INSTANCE checks if the class is finalized + ;; and if not, tries to finalize it. + (unless (class-finalized-p class) + (std-finalize-inheritance class)) + (sys::%std-allocate-instance class)) + (defun make-instance-standard-class (metaclass &rest initargs &key name direct-superclasses direct-slots