From ehuelsmann at common-lisp.net Sat Aug 1 07:58:23 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 01 Aug 2009 03:58:23 -0400 Subject: [armedbear-cvs] r12082 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 1 03:58:15 2009 New Revision: 12082 Log: Hot spot counting for the profiler. Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java trunk/abcl/src/org/armedbear/lisp/Profiler.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 Sat Aug 1 03:58:15 2009 @@ -834,6 +834,18 @@ public void incrementCallCounts() throws ConditionThrowable { StackFrame s = stack; + + for (int i = 0; i < 8; i++) { + if (s == null) + break; + LispObject operator = s.operator; + if (operator != null) { + operator.incrementHotCount(); + operator.incrementCallCount(); + } + s = s.next; + } + while (s != null) { LispObject operator = s.operator; if (operator != null) Modified: trunk/abcl/src/org/armedbear/lisp/Profiler.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Profiler.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Profiler.java Sat Aug 1 03:58:15 2009 @@ -68,12 +68,14 @@ LispObject object = symbol.getSymbolFunction(); if (object != null) { object.setCallCount(0); + object.setHotCount(0); if (object instanceof StandardGenericFunction) { LispObject methods = PACKAGE_MOP.intern("GENERIC-FUNCTION-METHODS").execute(object); while (methods != NIL) { StandardMethod method = (StandardMethod) methods.car(); method.getFunction().setCallCount(0); + method.getFunction().setHotCount(0); methods = methods.cdr(); } } From astalla at common-lisp.net Wed Aug 5 18:16:59 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Wed, 05 Aug 2009 14:16:59 -0400 Subject: [armedbear-cvs] r12083 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Wed Aug 5 14:16:57 2009 New Revision: 12083 Log: Fixed (reverted) wrong implementation of JavaObject.javaInstance(Class) introduced with revision 12081. Fixed incorrect wrapping of LispObjects that are elements of a Java array when the array is inspected. Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JavaObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/JavaObject.java Wed Aug 5 14:16:57 2009 @@ -176,12 +176,7 @@ @Override public Object javaInstance(Class c) throws ConditionThrowable { - if(obj != null && !c.isAssignableFrom(obj.getClass())) { - return error(new LispError("The value " + obj + - " is not of class " + c.getName())); - } else { - return javaInstance(); - } + return javaInstance(); } /** Returns the encapsulated Java object for @@ -263,7 +258,7 @@ int length = Array.getLength(obj); for(int i = 0; i < length; i++) { parts = parts.push - (new Cons(empty, new JavaObject(Array.get(obj, i)))); + (new Cons(empty, JavaObject.getInstance(Array.get(obj, i)))); } parts = parts.nreverse(); } else { @@ -284,7 +279,9 @@ @Override public LispObject execute(LispObject arg) throws ConditionThrowable { - Class c = (Class) arg.javaInstance(Class.class); + //No possibility of type error - we're mapping this function + //over a list of classes + Class c = (Class) arg.javaInstance(); for(Field f : c.getDeclaredFields()) { LispObject value = NIL; try { From ehuelsmann at common-lisp.net Sat Aug 8 14:15:35 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 08 Aug 2009 10:15:35 -0400 Subject: [armedbear-cvs] r12084 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 8 10:15:32 2009 New Revision: 12084 Log: Declaration (processing) fixes. jvm.lisp (process-ignore/ignorable): Don't process function-binding declarations as if they were variables. clos.lisp: declare CALL-NEXT-METHOD and NEXT-METHOD-P as ignorable function bindings (instead of variables). Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Aug 8 10:15:32 2009 @@ -1586,7 +1586,8 @@ (funcall next-emfun (or cnm-args args)))) (next-method-p () (not (null next-emfun)))) - (declare (ignorable call-next-method next-method-p)) + (declare (ignorable (function call-next-method) + (function next-method-p))) (apply #'(lambda ,lambda-list , at declarations , at body) args)))) ((null (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux))) ;; Required parameters only. 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 Aug 8 10:15:32 2009 @@ -479,17 +479,18 @@ (when (memq declaration '(IGNORE IGNORABLE)) (let ((what (if (eq declaration 'IGNORE) "ignored" "ignorable"))) (dolist (name names) - (let ((variable (find-variable name variables))) - (cond ((null variable) - (compiler-style-warn "Declaring unknown variable ~S to be ~A." - name what)) - ((variable-special-p variable) - (compiler-style-warn "Declaring special variable ~S to be ~A." - name what)) - ((eq declaration 'IGNORE) - (setf (variable-ignore-p variable) t)) - (t - (setf (variable-ignorable-p variable) t)))))))) + (unless (and (consp name) (eq (car name) 'FUNCTION)) + (let ((variable (find-variable name variables))) + (cond ((null variable) + (compiler-style-warn "Declaring unknown variable ~S to be ~A." + name what)) + ((variable-special-p variable) + (compiler-style-warn "Declaring special variable ~S to be ~A." + name what)) + ((eq declaration 'IGNORE) + (setf (variable-ignore-p variable) t)) + (t + (setf (variable-ignorable-p variable) t))))))))) (defun finalize-generic-functions () (dolist (sym '(make-instance From ehuelsmann at common-lisp.net Sat Aug 8 15:18:12 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 08 Aug 2009 11:18:12 -0400 Subject: [armedbear-cvs] r12085 - trunk/abcl Message-ID: Author: ehuelsmann Date: Sat Aug 8 11:18:10 2009 New Revision: 12085 Log: Fix for running the wrapper on a path with spaces in it - Windows. Modified: trunk/abcl/abcl.bat.in Modified: trunk/abcl/abcl.bat.in ============================================================================== --- trunk/abcl/abcl.bat.in (original) +++ trunk/abcl/abcl.bat.in Sat Aug 8 11:18:10 2009 @@ -1 +1 @@ -@"@JAVA@" @ABCL_JAVA_OPTIONS@ @ABCL_JAVA_OPTIONS@ -cp @ABCL_CLASSPATH@ org.armedbear.lisp.Main %1 %2 %3 %4 %5 %6 %7 %8 %9 +@"@JAVA@" @ABCL_JAVA_OPTIONS@ @ABCL_JAVA_OPTIONS@ -cp "@ABCL_CLASSPATH@" org.armedbear.lisp.Main %1 %2 %3 %4 %5 %6 %7 %8 %9 From ehuelsmann at common-lisp.net Sat Aug 8 15:20:29 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 08 Aug 2009 11:20:29 -0400 Subject: [armedbear-cvs] r12086 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 8 11:20:28 2009 New Revision: 12086 Log: Make every form which may contain free specials declarations a BLOCK-NODE. LOCALLY, FLET and LABELS were not converted to blocks - yet. While at it, change the block dispatch routine: we're not smart enough to detect that the (block-name form) form will generate the same value every time - so we don't cache the function result, but evaluate it each time. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.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 Aug 8 11:20:28 2009 @@ -233,13 +233,17 @@ block)) (defun p1-locally (form) - (let ((*visible-variables* *visible-variables*) - (specials (process-special-declarations (cdr form)))) - (dolist (name specials) + (let* ((*visible-variables* *visible-variables*) + (block (make-block-node '(LOCALLY))) + (free-specials (process-declarations-for-vars (cdr form) nil))) + (setf (block-free-specials block) free-specials) + (dolist (special free-specials) ;; (format t "p1-locally ~S is special~%" name) - (push (make-variable :name name :special-p t) *visible-variables*)) - (setf (cdr form) (p1-body (cdr form))) - form)) + (push special *visible-variables*)) + (let ((*blocks* (cons block *blocks*))) + (setf (block-form block) + (list* 'LOCALLY (p1-body (cdr form)))) + block))) (defknown p1-m-v-b (t) t) (defun p1-m-v-b (form) @@ -631,7 +635,17 @@ (push local-function local-functions))) ((with-saved-compiler-policy (process-optimization-declarations (cddr form)) - (list* (car form) local-functions (p1-body (cddr form))))))) + (let* ((block (make-block-node '(FLET))) + (*blocks* (cons block *blocks*)) + (body (cddr form)) + (*visible-variables* *visible-variables*)) + (setf (block-free-specials block) + (process-declarations-for-vars body nil)) + (dolist (special (block-free-specials block)) + (push special *visible-variables*)) + (setf (block-form block) + (list* (car form) local-functions (p1-body (cddr form)))) + block))))) (defun p1-labels (form) @@ -651,7 +665,17 @@ (let ((*visible-variables* *visible-variables*) (*current-compiland* (local-function-compiland local-function))) (p1-compiland (local-function-compiland local-function)))) - (list* (car form) local-functions (p1-body (cddr form)))))) + (let* ((block (make-block-node '(LABELS))) + (*blocks* (cons block *blocks*)) + (body (cddr form)) + (*visible-variables* *visible-variables*)) + (setf (block-free-specials block) + (process-declarations-for-vars body nil)) + (dolist (special (block-free-specials block)) + (push special *visible-variables*)) + (setf (block-form block) + (list* (car form) local-functions (p1-body (cddr form)))) + block)))) (defknown p1-funcall (t) t) (defun p1-funcall (form) 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 Aug 8 11:20:28 2009 @@ -4436,13 +4436,13 @@ (restore-environment-and-make-handler (block-environment-register block) label-START)))) -(defun p2-locally (form target representation) +(defknown p2-locally-node (t t t) t) +(defun p2-locally-node (block target representation) (with-saved-compiler-policy - (let* ((body (cdr form)) - (*visible-variables* *visible-variables*) - (specials (process-special-declarations body))) - (dolist (name specials) - (push (make-variable :name name :special-p t) *visible-variables*)) + (let* ((body (cdr (block-form block))) + (*visible-variables* (append (block-free-specials block) + *visible-variables*)) + (*blocks* (cons block *blocks*))) (process-optimization-declarations body) (compile-progn-body body target representation)))) @@ -4952,26 +4952,28 @@ (emit-make-compiled-closure-for-flet/labels local-function compiland g))))))) -(defknown p2-flet (t t t) t) -(defun p2-flet (form target representation) - (let ((*local-functions* *local-functions*) - (*visible-variables* *visible-variables*) - (local-functions (cadr form)) - (body (cddr form))) +(defknown p2-flet-node (t t t) t) +(defun p2-flet-node (block target representation) + (let* ((form (block-form block)) + (*local-functions* *local-functions*) + (*visible-variables* *visible-variables*) + (local-functions (cadr form)) + (body (cddr form))) (dolist (local-function local-functions) (p2-flet-process-compiland local-function)) (dolist (local-function local-functions) (push local-function *local-functions*)) - (dolist (special (process-special-declarations body)) - (push (make-variable :name special :special-p t) *visible-variables*)) + (dolist (special (block-free-specials block)) + (push special *visible-variables*)) (compile-progn-body body target representation))) -(defknown p2-labels (t t t) t) -(defun p2-labels (form target representation) - (let ((*local-functions* *local-functions*) - (*visible-variables* *visible-variables*) - (local-functions (cadr form)) - (body (cddr form))) +(defknown p2-labels-node (t t t) t) +(defun p2-labels-node (block target representation) + (let* ((form (block-form block)) + (*local-functions* *local-functions*) + (*visible-variables* *visible-variables*) + (local-functions (cadr form)) + (body (cddr form))) (dolist (local-function local-functions) (push local-function *local-functions*) (push (local-function-variable local-function) *visible-variables*)) @@ -4982,8 +4984,8 @@ (setf (variable-register variable) (allocate-register))))) (dolist (local-function local-functions) (p2-labels-process-compiland local-function)) - (dolist (special (process-special-declarations body)) - (push (make-variable :name special :special-p t) *visible-variables*)) + (dolist (special (block-free-specials block)) + (push special *visible-variables*)) (compile-progn-body body target representation))) (defun p2-lambda (compiland target) @@ -7901,27 +7903,35 @@ ((var-ref-p form) (compile-var-ref form target representation)) ((block-node-p form) - (cond ((equal (block-name form) '(TAGBODY)) - (p2-tagbody-node form target) - (fix-boxing representation nil)) - ((equal (block-name form) '(LET)) - (p2-let/let*-node form target representation)) - ((equal (block-name form) '(MULTIPLE-VALUE-BIND)) - (p2-m-v-b-node form target) - (fix-boxing representation nil)) - ((equal (block-name form) '(UNWIND-PROTECT)) - (p2-unwind-protect-node form target) - (fix-boxing representation nil)) - ((equal (block-name form) '(CATCH)) - (p2-catch-node form target) - (fix-boxing representation nil)) - ((equal (block-name form) '(PROGV)) - (p2-progv-node form target representation)) - ((equal (block-name form) '(THREADS:SYNCHRONIZED-ON)) - (p2-threads-synchronized-on form target) - (fix-boxing representation nil)) - (t - (p2-block-node form target representation)))) + (let ((name (block-name form))) + (if (not (consp name)) + (p2-block-node form target representation) + (let ((name (car name))) + (cond ((eq name 'TAGBODY) + (p2-tagbody-node form target) + (fix-boxing representation nil)) + ((eq name 'LET) + (p2-let/let*-node form target representation)) + ((eq name 'FLET) + (p2-flet-node form target representation)) + ((eq name 'LABELS) + (p2-labels-node form target representation)) + ((eq name 'MULTIPLE-VALUE-BIND) + (p2-m-v-b-node form target) + (fix-boxing representation nil)) + ((eq name 'UNWIND-PROTECT) + (p2-unwind-protect-node form target) + (fix-boxing representation nil)) + ((eq name 'CATCH) + (p2-catch-node form target) + (fix-boxing representation nil)) + ((eq name 'PROGV) + (p2-progv-node form target representation)) + ((eq name 'LOCALLY) + (p2-locally-node form target representation)) + ((eq name 'THREADS:SYNCHRONIZED-ON) + (p2-threads-synchronized-on form target) + (fix-boxing representation nil))))))) ((constantp form) (compile-constant form target representation)) (t @@ -8596,7 +8606,6 @@ (install-p2-handler 'eval-when 'p2-eval-when) (install-p2-handler 'find-class 'p2-find-class) (install-p2-handler 'fixnump 'p2-fixnump) - (install-p2-handler 'flet 'p2-flet) (install-p2-handler 'funcall 'p2-funcall) (install-p2-handler 'function 'p2-function) (install-p2-handler 'gensym 'p2-gensym) @@ -8606,14 +8615,12 @@ (install-p2-handler 'gethash1 'p2-gethash) (install-p2-handler 'go 'p2-go) (install-p2-handler 'if 'p2-if) - (install-p2-handler 'labels 'p2-labels) (install-p2-handler 'length 'p2-length) (install-p2-handler 'list 'p2-list) (install-p2-handler 'sys::backq-list 'p2-list) (install-p2-handler 'list* 'p2-list*) (install-p2-handler 'sys::backq-list* 'p2-list*) (install-p2-handler 'load-time-value 'p2-load-time-value) - (install-p2-handler 'locally 'p2-locally) (install-p2-handler 'logand 'p2-logand) (install-p2-handler 'logior 'p2-logior) (install-p2-handler 'lognot 'p2-lognot) From ehuelsmann at common-lisp.net Sat Aug 8 15:31:14 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 08 Aug 2009 11:31:14 -0400 Subject: [armedbear-cvs] r12087 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 8 11:31:13 2009 New Revision: 12087 Log: Publish free specials declared in MULTIPLE-VALUE-BIND statements (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 Aug 8 11:31:13 2009 @@ -272,6 +272,8 @@ (block-environment-register block) t))) (setf (block-free-specials block) (process-declarations-for-vars body vars)) + (dolist (special (block-free-specials block)) + (push special *visible-variables*)) (setf (block-vars block) (nreverse vars))) (setf body (p1-body body)) (setf (block-form block) From ehuelsmann at common-lisp.net Sat Aug 8 19:18:33 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 08 Aug 2009 15:18:33 -0400 Subject: [armedbear-cvs] r12088 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 8 15:18:31 2009 New Revision: 12088 Log: Register blocks with their compiland; create a field in the variable-info structure to allow registration of the block they belong to. 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 Aug 8 15:18:31 2009 @@ -162,6 +162,7 @@ parent ; the parent for compilands which defined within another (children 0 ; Number of local functions :type fixnum) ; defined with with FLET, LABELS or LAMBDA + blocks ; TAGBODY, PROGV, BLOCK, etc. blocks argument-register closure-register environment-register @@ -271,7 +272,8 @@ (references-allowed-p t) ; NIL if this is a symbol macro in the enclosing ; lexical environment used-non-locally-p - (compiland *current-compiland*)) + (compiland *current-compiland*) + block) (defstruct (var-ref (:constructor make-var-ref (variable))) ;; The variable this reference refers to. Will be NIL if the VAR-REF has been @@ -369,7 +371,7 @@ ;; BLOCKs per se. (defstruct (block-node (:conc-name block-) (:include node) - (:constructor make-block-node (name))) + (:constructor %make-block-node (name))) (exit (gensym)) target catch-tag @@ -394,6 +396,12 @@ (defvar *blocks* ()) +(defknown make-block-node (t) t) +(defun make-block-node (name) + (let ((block (%make-block-node name))) + (push block (compiland-blocks *current-compiland*)) + block)) + (defun find-block (name) (dolist (block *blocks*) (when (eq name (block-name block)) From ehuelsmann at common-lisp.net Sat Aug 8 20:43:12 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 08 Aug 2009 16:43:12 -0400 Subject: [armedbear-cvs] r12089 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 8 16:43:10 2009 New Revision: 12089 Log: Refer to blocks upon variable creation, wherever appropriate. 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 Aug 8 16:43:10 2009 @@ -60,8 +60,9 @@ ;; Returns a list of declared free specials, if any are found. -(declaim (ftype (function (list list) list) process-declarations-for-vars)) -(defun process-declarations-for-vars (body variables) +(declaim (ftype (function (list list block-node) list) + process-declarations-for-vars)) +(defun process-declarations-for-vars (body variables block) (let ((free-specials '())) (dolist (subform body) (unless (and (consp subform) (eq (%car subform) 'DECLARE)) @@ -84,7 +85,8 @@ (setf (variable-special-p variable) t)) (t (dformat t "adding free special ~S~%" name) - (push (make-variable :name name :special-p t) + (push (make-variable :name name :special-p t + :block block) free-specials)))))) (TYPE (dolist (name (cddr decl)) @@ -149,7 +151,7 @@ (defmacro p1-let/let*-vars - (varlist variables-var var body1 body2) + (block varlist variables-var var body1 body2) (let ((varspec (gensym)) (initform (gensym)) (name (gensym))) @@ -165,18 +167,20 @@ (let* ((,name (%car ,varspec)) (,initform (p1 (%cadr ,varspec))) (,var (make-variable :name (check-name ,name) - :initform ,initform))) + :initform ,initform + :block ,block))) (push ,var ,variables-var) , at body1)) (t - (let ((,var (make-variable :name (check-name ,varspec)))) + (let ((,var (make-variable :name (check-name ,varspec) + :block ,block))) (push ,var ,variables-var) , at body1)))) , at body2))) (defknown p1-let-vars (t) t) -(defun p1-let-vars (varlist) - (p1-let/let*-vars +(defun p1-let-vars (block varlist) + (p1-let/let*-vars block varlist vars var () ((setf vars (nreverse vars)) @@ -186,8 +190,8 @@ vars))) (defknown p1-let*-vars (t) t) -(defun p1-let*-vars (varlist) - (p1-let/let*-vars +(defun p1-let*-vars (block varlist) + (p1-let/let*-vars block varlist vars var ((push var *visible-variables*) (push var *all-variables*)) @@ -212,8 +216,8 @@ (eq (car varspec) (cadr varspec)) (return))))) (let ((vars (if (eq op 'LET) - (p1-let-vars varlist) - (p1-let*-vars varlist)))) + (p1-let-vars block varlist) + (p1-let*-vars block varlist)))) ;; Check for globally declared specials. (dolist (variable vars) (when (special-variable-p (variable-name variable)) @@ -223,7 +227,7 @@ ;; last to first, since declarations apply to the last-defined variable ;; with the specified name. (setf (block-free-specials block) - (process-declarations-for-vars body (reverse vars))) + (process-declarations-for-vars body (reverse vars) block)) (setf (block-vars block) vars) ;; Make free specials visible. (dolist (variable (block-free-specials block)) @@ -235,7 +239,7 @@ (defun p1-locally (form) (let* ((*visible-variables* *visible-variables*) (block (make-block-node '(LOCALLY))) - (free-specials (process-declarations-for-vars (cdr form) nil))) + (free-specials (process-declarations-for-vars (cdr form) nil block))) (setf (block-free-specials block) free-specials) (dolist (special free-specials) ;; (format t "p1-locally ~S is special~%" name) @@ -261,7 +265,7 @@ (setf values-form (p1 values-form)) (let ((vars ())) (dolist (symbol varlist) - (let ((var (make-variable :name symbol))) + (let ((var (make-variable :name symbol :block block))) (push var vars) (push var *visible-variables*) (push var *all-variables*))) @@ -271,7 +275,7 @@ (setf (variable-special-p variable) t (block-environment-register block) t))) (setf (block-free-specials block) - (process-declarations-for-vars body vars)) + (process-declarations-for-vars body vars block)) (dolist (special (block-free-specials block)) (push special *visible-variables*)) (setf (block-vars block) (nreverse vars))) @@ -642,7 +646,7 @@ (body (cddr form)) (*visible-variables* *visible-variables*)) (setf (block-free-specials block) - (process-declarations-for-vars body nil)) + (process-declarations-for-vars body nil block)) (dolist (special (block-free-specials block)) (push special *visible-variables*)) (setf (block-form block) @@ -672,7 +676,7 @@ (body (cddr form)) (*visible-variables* *visible-variables*)) (setf (block-free-specials block) - (process-declarations-for-vars body nil)) + (process-declarations-for-vars body nil block)) (dolist (special (block-free-specials block)) (push special *visible-variables*)) (setf (block-form block) @@ -770,8 +774,6 @@ (defun p1-progv (form) ;; We've already checked argument count in PRECOMPILE-PROGV. - ;; ### FIXME: we need to return a block here, so that - ;; (local) GO in p2 can restore the lastSpecialBinding environment (let ((new-form (rewrite-progv form))) (when (neq new-form form) (return-from p1-progv (p1 new-form)))) @@ -780,6 +782,14 @@ (block (make-block-node '(PROGV))) (*blocks* (cons block *blocks*)) (body (cdddr form))) +;; The (commented out) block below means to detect compile-time +;; enumeration of bindings to be created (a quoted form in the symbols +;; position). +;; (when (and (quoted-form-p symbols-form) +;; (listp (second symbols-form))) +;; (dolist (name (second symbols-form)) +;; (let ((variable (make-variable :name name :special-p t))) +;; (push (setf (block-form block) `(progv ,symbols-form ,values-form ,@(p1-body body)) (block-environment-register block) t) @@ -1109,7 +1119,7 @@ (push var *all-variables*) (push var *visible-variables*))) (setf (compiland-arg-vars compiland) (nreverse vars)) - (let ((free-specials (process-declarations-for-vars body vars))) + (let ((free-specials (process-declarations-for-vars body vars nil))) (setf (compiland-free-specials compiland) free-specials) (dolist (var free-specials) (push var *visible-variables*))) From ehuelsmann at common-lisp.net Sat Aug 8 20:48:50 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 08 Aug 2009 16:48:50 -0400 Subject: [armedbear-cvs] r12090 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 8 16:48:49 2009 New Revision: 12090 Log: Use PROCESS-DECLARATIONS-FOR-VARS in compile-file.lisp. Rationale: Use package internals which return the required information, so that we don't need to create it ourselves. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sat Aug 8 16:48:49 2009 @@ -245,10 +245,10 @@ (parse-body (cdr form) nil) (process-optimization-declarations decls) (let* ((jvm::*visible-variables* jvm::*visible-variables*) - (specials (process-special-declarations decls))) + (specials (jvm::process-declarations-for-vars (cdr form) + nil nil))) (dolist (special specials) - (push (jvm::make-variable :name special :special-p t) - jvm::*visible-variables*)) + (push special jvm::*visible-variables*)) (process-toplevel-progn forms stream compile-time-too)) (return-from process-toplevel-form)))) (PROGN From ehuelsmann at common-lisp.net Tue Aug 11 11:35:42 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 11 Aug 2009 07:35:42 -0400 Subject: [armedbear-cvs] r12091 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Aug 11 07:35:39 2009 New Revision: 12091 Log: Remove condition from another era (when TAGBODY-s used to store a environment themselves). 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 Tue Aug 11 07:35:39 2009 @@ -449,8 +449,7 @@ (dolist (enclosing-block *blocks*) (when (eq enclosing-block outermost-block) (return nil)) - (when (and (block-environment-register enclosing-block) - (not (block-needs-environment-restoration enclosing-block))) + (when (and (block-environment-register enclosing-block)) (return t)))) (defknown environment-register-to-restore (&optional t) t) From ehuelsmann at common-lisp.net Tue Aug 11 11:38:01 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 11 Aug 2009 07:38:01 -0400 Subject: [armedbear-cvs] r12092 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Aug 11 07:38:00 2009 New Revision: 12092 Log: With node/block changes ahead: when unsure about the actual type of the node being accessed, use NODE accessors. 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 Tue Aug 11 07:38:00 2009 @@ -404,7 +404,7 @@ (defun find-block (name) (dolist (block *blocks*) - (when (eq name (block-name block)) + (when (eq name (node-name block)) (return block)))) (defknown node-constant-p (t) boolean) @@ -426,7 +426,7 @@ Non-local exits are required by blocks which do more in their cleanup than just restore the lastSpecialBinding (= dynamic environment). " - (let ((name (block-name object))) + (let ((name (node-name object))) (or (equal name '(CATCH)) (equal name '(UNWIND-PROTECT)) (equal name '(THREADS:SYNCHRONIZED-ON))))) From ehuelsmann at common-lisp.net Tue Aug 11 11:41:02 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 11 Aug 2009 07:41:02 -0400 Subject: [armedbear-cvs] r12093 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Aug 11 07:41:01 2009 New Revision: 12093 Log: Introduce a structure-class hierarchy for nodes. 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 Tue Aug 11 07:41:01 2009 @@ -367,10 +367,70 @@ form (compiland *current-compiland*)) +;; control-transferring blocks: TAGBODY, CATCH, to do: BLOCK + +(defstruct (control-transferring-node (:include node)) + ;; If non-nil, the TAGBODY contains local blocks which "contaminate" the + ;; environment, with GO forms in them which target tags in this TAGBODY + ;; Non-nil if and only if the block doesn't modify the environment + needs-environment-restoration + ) + +(defstruct (tagbody-node (:conc-name tagbody-) + (:include control-transferring-node)) + ;; True if a tag in this tagbody is the target of a non-local GO. + non-local-go-p + tags) + +(defstruct (catch-node (:conc-name catch-) + (:include control-transferring-node)) + ;; fixme? tag gotten from the catch-form + ) + +;; block-node belongs here; it's down below for historical raisins + +;; binding blocks: LET, LET*, FLET, LABELS, M-V-B, PROGV, LOCALLY + +(defstruct (binding-node (:include node)) + ;; If non-nil, register containing saved dynamic environment for this block. + environment-register + ;; Not used for LOCALLY, FLET, LABELS + vars + free-specials) + +(defstruct (let/let*-node (:conc-name let-) + (:include binding-node))) + +(defstruct (flet-node (:conc-name flet-) + (:include binding-node))) + +(defstruct (labels-node (:conc-name labels-) + (:include binding-node))) + +(defstruct (m-v-b-node (:conc-name m-v-b-) + (:include binding-node))) + +(defstruct (progv-node (:conc-name progv-) + (:include binding-node))) + +(defstruct (locally-node (:conc-name locally-) + (:include binding-node))) + +;; blocks requiring non-local exits: UNWIND-PROTECT, SYS:SYNCHRONIZED-ON + +(defstruct (protected-node (:include node))) + +(defstruct (unwind-protect-node (:conc-name unwind-protect-) + (:include protected-node))) + +(defstruct (synchronized-node (:conc-name synchronized-) + (:include protected-node))) + + ;; Used to wrap TAGBODYs, UNWIND-PROTECTs and LET/LET*/M-V-B forms as well as ;; BLOCKs per se. (defstruct (block-node (:conc-name block-) - (:include node) + (:include control-transferring-node) (:constructor %make-block-node (name))) (exit (gensym)) target @@ -381,10 +441,6 @@ non-local-return-p ;; True if a tag in this tagbody is the target of a non-local GO. non-local-go-p - ;; If non-nil, the TAGBODY contains local blocks which "contaminate" the - ;; environment, with GO forms in them which target tags in this TAGBODY - ;; Non-nil if and only if the block doesn't modify the environment - needs-environment-restoration ;; If non-nil, register containing saved dynamic environment for this block. environment-register ;; Only used in LET/LET*/M-V-B nodes. From ehuelsmann at common-lisp.net Tue Aug 11 15:41:43 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 11 Aug 2009 11:41:43 -0400 Subject: [armedbear-cvs] r12094 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Aug 11 11:41:40 2009 New Revision: 12094 Log: Convert TAGBODY block-nodes to TAGBODY-NODEs. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Tue Aug 11 11:41:40 2009 @@ -368,7 +368,7 @@ ;; which is inside the block we're returning from, we'll do a non- ;; local return anyway so that UNWIND-PROTECT can catch it and run ;; its cleanup forms. - (dformat t "*blocks* = ~S~%" (mapcar #'block-name *blocks*)) + (dformat t "*blocks* = ~S~%" (mapcar #'node-name *blocks*)) (let ((protected (enclosed-by-protected-block-p block))) (dformat t "p1-return-from protected = ~S~%" protected) (if protected @@ -385,7 +385,7 @@ (list* 'RETURN-FROM (cadr form) (mapcar #'p1 (cddr form)))) (defun p1-tagbody (form) - (let* ((block (make-block-node '(TAGBODY))) + (let* ((block (make-tagbody-node :name '(TAGBODY))) (*blocks* (cons block *blocks*)) (*visible-tags* *visible-tags*) (local-tags '()) @@ -402,7 +402,7 @@ (cond ((or (symbolp subform) (integerp subform)) (push subform new-body) (push (find subform local-tags :key #'tag-name :test #'eql) - (block-tags block)) + (tagbody-tags block)) (setf live t)) ((not live) ;; Nothing to do. @@ -414,7 +414,7 @@ ;; tag. (setf live nil)) (push (p1 subform) new-body)))) - (setf (block-form block) (list* 'TAGBODY (nreverse new-body)))) + (setf (tagbody-form block) (list* 'TAGBODY (nreverse new-body)))) block)) (defknown p1-go (t) t) @@ -428,14 +428,14 @@ (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 (block-non-local-go-p tag-block) t) + (setf (tagbody-non-local-go-p tag-block) t) ;; non-local GO's ensure environment restoration ;; find out about this local GO - (when (null (block-needs-environment-restoration tag-block)) - (setf (block-needs-environment-restoration tag-block) + (when (null (tagbody-needs-environment-restoration tag-block)) + (setf (tagbody-needs-environment-restoration tag-block) (enclosed-by-environment-setting-block-p tag-block))))) (t - (setf (block-non-local-go-p tag-block) t))))) + (setf (tagbody-non-local-go-p tag-block) t))))) form) (defun validate-function-name (name) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Aug 11 11:41:40 2009 @@ -836,8 +836,8 @@ (defknown single-valued-p (t) t) (defun single-valued-p (form) - (cond ((block-node-p form) - (if (equal (block-name form) '(TAGBODY)) + (cond ((node-p form) + (if (equal (node-name form) '(TAGBODY)) (not (unsafe-p (node-form form))) (single-valued-p (node-form form)))) ((var-ref-p form) @@ -4451,14 +4451,14 @@ (let* ((*blocks* (cons block *blocks*)) (*visible-tags* *visible-tags*) (*register* *register*) - (form (block-form block)) + (form (tagbody-form block)) (body (cdr form)) (BEGIN-BLOCK (gensym)) (END-BLOCK (gensym)) (EXIT (gensym)) (must-clear-values nil)) ;; Scan for tags. - (dolist (tag (block-tags block)) + (dolist (tag (tagbody-tags block)) (push tag *visible-tags*)) (label BEGIN-BLOCK) @@ -4466,7 +4466,7 @@ (subform (car rest) (car rest))) ((null rest)) (cond ((or (symbolp subform) (integerp subform)) - (let ((tag (find subform (block-tags block) :key #'tag-name + (let ((tag (find subform (tagbody-tags block) :key #'tag-name :test #'eql))) (unless tag (error "COMPILE-TAGBODY: tag not found: ~S~%" subform)) @@ -4481,7 +4481,7 @@ (setf must-clear-values t)))))) (label END-BLOCK) (emit 'goto EXIT) - (when (block-non-local-go-p block) + (when (tagbody-non-local-go-p block) ; We need a handler to catch non-local GOs. (let* ((HANDLER (gensym)) (*register* *register*) @@ -4497,7 +4497,7 @@ (astore tag-register) ;; Don't actually generate comparisons for tags ;; to which there is no GO instruction - (dolist (tag (remove-if-not #'tag-used (block-tags block))) + (dolist (tag (remove-if-not #'tag-used (tagbody-tags block))) (let ((NEXT (gensym))) (aload tag-register) (emit 'getstatic *this-class* @@ -4539,7 +4539,7 @@ (not (enclosed-by-protected-block-p tag-block))) ;; Local case with local transfer of control ;; Note: Local case with non-local transfer of control handled below - (when (and (block-needs-environment-restoration tag-block) + (when (and (tagbody-needs-environment-restoration tag-block) (enclosed-by-environment-setting-block-p tag-block)) ;; If there's a dynamic environment to restore, do it. (restore-dynamic-environment (environment-register-to-restore tag-block))) @@ -6408,11 +6408,11 @@ (if variable (derive-type variable) t))))) - ((block-node-p form) + ((node-p form) (let ((result t)) - (cond ((equal (block-name form) '(LET)) + (cond ((equal (node-name form) '(LET)) ;; (format t "derive-type LET/LET* node case~%") - (let* ((forms (cddr (block-form form))) + (let* ((forms (cddr (node-form form))) (last-form (car (last forms))) (derived-type (derive-compiler-type last-form))) ;; (unless (eq derived-type t) @@ -6421,7 +6421,7 @@ ;; (format t "derived-type = ~S~%" derived-type) ;; ) (setf result derived-type))) - ((symbolp (block-name form)) + ((symbolp (node-name form)) (unless (block-return-p form) (let* ((forms (cddr (block-form form))) (last-form (car (last forms))) @@ -7907,31 +7907,45 @@ (if (not (consp name)) (p2-block-node form target representation) (let ((name (car name))) - (cond ((eq name 'TAGBODY) - (p2-tagbody-node form target) - (fix-boxing representation nil)) - ((eq name 'LET) - (p2-let/let*-node form target representation)) - ((eq name 'FLET) - (p2-flet-node form target representation)) - ((eq name 'LABELS) - (p2-labels-node form target representation)) - ((eq name 'MULTIPLE-VALUE-BIND) - (p2-m-v-b-node form target) - (fix-boxing representation nil)) - ((eq name 'UNWIND-PROTECT) - (p2-unwind-protect-node form target) - (fix-boxing representation nil)) - ((eq name 'CATCH) - (p2-catch-node form target) - (fix-boxing representation nil)) - ((eq name 'PROGV) - (p2-progv-node form target representation)) - ((eq name 'LOCALLY) - (p2-locally-node form target representation)) - ((eq name 'THREADS:SYNCHRONIZED-ON) - (p2-threads-synchronized-on form target) - (fix-boxing representation nil))))))) + (cond + ((eq name 'LET) + (p2-let/let*-node form target representation)) + ((eq name 'FLET) + (p2-flet-node form target representation)) + ((eq name 'LABELS) + (p2-labels-node form target representation)) + ((eq name 'MULTIPLE-VALUE-BIND) + (p2-m-v-b-node form target) + (fix-boxing representation nil)) + ((eq name 'UNWIND-PROTECT) + (p2-unwind-protect-node form target) + (fix-boxing representation nil)) + ((eq name 'CATCH) + (p2-catch-node form target) + (fix-boxing representation nil)) + ((eq name 'PROGV) + (p2-progv-node form target representation)) + ((eq name 'LOCALLY) + (p2-locally-node form target representation)) + ((eq name 'THREADS:SYNCHRONIZED-ON) + (p2-threads-synchronized-on form target) + (fix-boxing representation nil))))))) + ((node-p form) + (cond + ((tagbody-node-p form) + (p2-tagbody-node form target) + (fix-boxing representation nil)) + ((unwind-protect-node-p form) + (p2-unwind-protect-node form target) + (fix-boxing representation nil)) + ((locally-node-p form) + (p2-locally-node form target representation)) + ((catch-node-p form) + (p2-catch-node form target) + (fix-boxing representation nil)) + ((progv-node-p form) + (p2-progv-node form target representation)) +)) ((constantp form) (compile-constant form target representation)) (t Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Tue Aug 11 11:41:40 2009 @@ -446,8 +446,6 @@ ;; Only used in LET/LET*/M-V-B nodes. vars free-specials - ;; Only used in TAGBODY - tags ) (defvar *blocks* ()) @@ -465,7 +463,7 @@ (defknown node-constant-p (t) boolean) (defun node-constant-p (object) - (cond ((block-node-p object) + (cond ((node-p object) nil) ((var-ref-p object) nil) @@ -505,7 +503,10 @@ (dolist (enclosing-block *blocks*) (when (eq enclosing-block outermost-block) (return nil)) - (when (and (block-environment-register enclosing-block)) + (when (or (and (binding-node-p enclosing-block) + (binding-node-environment-register enclosing-block)) + (and (block-node-p enclosing-block) + (block-environment-register enclosing-block))) (return t)))) (defknown environment-register-to-restore (&optional t) t) @@ -517,7 +518,10 @@ (flet ((outermost-register (last-register block) (when (eq block outermost-block) (return-from environment-register-to-restore last-register)) - (or (block-environment-register block) + (or (and (binding-node-p block) + (binding-node-environment-register block)) + (and (block-node-p block) + (block-environment-register block)) last-register))) (reduce #'outermost-register *blocks* :initial-value nil))) From ehuelsmann at common-lisp.net Tue Aug 11 20:34:52 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 11 Aug 2009 16:34:52 -0400 Subject: [armedbear-cvs] r12095 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Aug 11 16:34:48 2009 New Revision: 12095 Log: Remove obsolete block-node slot. 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 Tue Aug 11 16:34:48 2009 @@ -439,8 +439,6 @@ return-p ;; True if there is a non-local RETURN from this block. non-local-return-p - ;; True if a tag in this tagbody is the target of a non-local GO. - non-local-go-p ;; If non-nil, register containing saved dynamic environment for this block. environment-register ;; Only used in LET/LET*/M-V-B nodes. From ehuelsmann at common-lisp.net Wed Aug 12 11:29:04 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 12 Aug 2009 07:29:04 -0400 Subject: [armedbear-cvs] r12096 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Aug 12 07:29:01 2009 New Revision: 12096 Log: Switch UNWIND-PROTECT block-nodes to UNWIND-PROTECT-NODEs. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Wed Aug 12 07:29:01 2009 @@ -340,7 +340,7 @@ ;; ;; However, p1 transforms the forms being processed, so, we ;; need to copy the forms to create a second copy. - (let* ((block (make-block-node '(UNWIND-PROTECT))) + (let* ((block (make-unwind-protect-node :name '(UNWIND-PROTECT))) ;; a bit of jumping through hoops... (unwinding-forms (p1-body (copy-tree (cddr form)))) (unprotected-forms (p1-body (cddr form))) @@ -348,7 +348,7 @@ ;; protected by the UNWIND-PROTECT block (*blocks* (cons block *blocks*)) (protected-form (p1 (cadr form)))) - (setf (block-form block) + (setf (unwind-protect-form block) `(unwind-protect ,protected-form (progn , at unwinding-forms) , at unprotected-forms)) 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 Wed Aug 12 07:29:01 2009 @@ -7783,7 +7783,7 @@ (emit-move-from-stack target))) (defun p2-unwind-protect-node (block target) - (let ((form (block-form block))) + (let ((form (unwind-protect-form block))) (when (= (length form) 2) ; No cleanup form. (compile-form (second form) target nil) (return-from p2-unwind-protect-node)) @@ -7902,40 +7902,12 @@ (aver nil)))) ((var-ref-p form) (compile-var-ref form target representation)) - ((block-node-p form) - (let ((name (block-name form))) - (if (not (consp name)) - (p2-block-node form target representation) - (let ((name (car name))) - (cond - ((eq name 'LET) - (p2-let/let*-node form target representation)) - ((eq name 'FLET) - (p2-flet-node form target representation)) - ((eq name 'LABELS) - (p2-labels-node form target representation)) - ((eq name 'MULTIPLE-VALUE-BIND) - (p2-m-v-b-node form target) - (fix-boxing representation nil)) - ((eq name 'UNWIND-PROTECT) - (p2-unwind-protect-node form target) - (fix-boxing representation nil)) - ((eq name 'CATCH) - (p2-catch-node form target) - (fix-boxing representation nil)) - ((eq name 'PROGV) - (p2-progv-node form target representation)) - ((eq name 'LOCALLY) - (p2-locally-node form target representation)) - ((eq name 'THREADS:SYNCHRONIZED-ON) - (p2-threads-synchronized-on form target) - (fix-boxing representation nil))))))) ((node-p form) (cond - ((tagbody-node-p form) + ((tagbody-node-p form) ;; done (p2-tagbody-node form target) (fix-boxing representation nil)) - ((unwind-protect-node-p form) + ((unwind-protect-node-p form) ;; done (p2-unwind-protect-node form target) (fix-boxing representation nil)) ((locally-node-p form) @@ -7945,6 +7917,32 @@ (fix-boxing representation nil)) ((progv-node-p form) (p2-progv-node form target representation)) + ((block-node-p form) + (let ((name (block-name form))) + (if (not (consp name)) + (p2-block-node form target representation) + ;; TODO: this branch of the IF is to be eliminated + (let ((name (car name))) + (cond + ((eq name 'LET) + (p2-let/let*-node form target representation)) + ((eq name 'FLET) + (p2-flet-node form target representation)) + ((eq name 'LABELS) + (p2-labels-node form target representation)) + ((eq name 'MULTIPLE-VALUE-BIND) + (p2-m-v-b-node form target) + (fix-boxing representation nil)) + ((eq name 'CATCH) + (p2-catch-node form target) + (fix-boxing representation nil)) + ((eq name 'LOCALLY) + (p2-locally-node form target representation)) + ((eq name 'PROGV) + (p2-progv-node form target representation)) + ((eq name 'THREADS:SYNCHRONIZED-ON) + (p2-threads-synchronized-on form target) + (fix-boxing representation nil))))))) )) ((constantp form) (compile-constant form target representation)) From ehuelsmann at common-lisp.net Wed Aug 12 20:41:47 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 12 Aug 2009 16:41:47 -0400 Subject: [armedbear-cvs] r12097 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Aug 12 16:41:44 2009 New Revision: 12097 Log: Revert r12096; restores build breakage. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Wed Aug 12 16:41:44 2009 @@ -340,7 +340,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 :name '(UNWIND-PROTECT))) + (let* ((block (make-block-node '(UNWIND-PROTECT))) ;; a bit of jumping through hoops... (unwinding-forms (p1-body (copy-tree (cddr form)))) (unprotected-forms (p1-body (cddr form))) @@ -348,7 +348,7 @@ ;; protected by the UNWIND-PROTECT block (*blocks* (cons block *blocks*)) (protected-form (p1 (cadr form)))) - (setf (unwind-protect-form block) + (setf (block-form block) `(unwind-protect ,protected-form (progn , at unwinding-forms) , at unprotected-forms)) 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 Wed Aug 12 16:41:44 2009 @@ -7783,7 +7783,7 @@ (emit-move-from-stack target))) (defun p2-unwind-protect-node (block target) - (let ((form (unwind-protect-form block))) + (let ((form (block-form block))) (when (= (length form) 2) ; No cleanup form. (compile-form (second form) target nil) (return-from p2-unwind-protect-node)) @@ -7902,12 +7902,40 @@ (aver nil)))) ((var-ref-p form) (compile-var-ref form target representation)) + ((block-node-p form) + (let ((name (block-name form))) + (if (not (consp name)) + (p2-block-node form target representation) + (let ((name (car name))) + (cond + ((eq name 'LET) + (p2-let/let*-node form target representation)) + ((eq name 'FLET) + (p2-flet-node form target representation)) + ((eq name 'LABELS) + (p2-labels-node form target representation)) + ((eq name 'MULTIPLE-VALUE-BIND) + (p2-m-v-b-node form target) + (fix-boxing representation nil)) + ((eq name 'UNWIND-PROTECT) + (p2-unwind-protect-node form target) + (fix-boxing representation nil)) + ((eq name 'CATCH) + (p2-catch-node form target) + (fix-boxing representation nil)) + ((eq name 'PROGV) + (p2-progv-node form target representation)) + ((eq name 'LOCALLY) + (p2-locally-node form target representation)) + ((eq name 'THREADS:SYNCHRONIZED-ON) + (p2-threads-synchronized-on form target) + (fix-boxing representation nil))))))) ((node-p form) (cond - ((tagbody-node-p form) ;; done + ((tagbody-node-p form) (p2-tagbody-node form target) (fix-boxing representation nil)) - ((unwind-protect-node-p form) ;; done + ((unwind-protect-node-p form) (p2-unwind-protect-node form target) (fix-boxing representation nil)) ((locally-node-p form) @@ -7917,32 +7945,6 @@ (fix-boxing representation nil)) ((progv-node-p form) (p2-progv-node form target representation)) - ((block-node-p form) - (let ((name (block-name form))) - (if (not (consp name)) - (p2-block-node form target representation) - ;; TODO: this branch of the IF is to be eliminated - (let ((name (car name))) - (cond - ((eq name 'LET) - (p2-let/let*-node form target representation)) - ((eq name 'FLET) - (p2-flet-node form target representation)) - ((eq name 'LABELS) - (p2-labels-node form target representation)) - ((eq name 'MULTIPLE-VALUE-BIND) - (p2-m-v-b-node form target) - (fix-boxing representation nil)) - ((eq name 'CATCH) - (p2-catch-node form target) - (fix-boxing representation nil)) - ((eq name 'LOCALLY) - (p2-locally-node form target representation)) - ((eq name 'PROGV) - (p2-progv-node form target representation)) - ((eq name 'THREADS:SYNCHRONIZED-ON) - (p2-threads-synchronized-on form target) - (fix-boxing representation nil))))))) )) ((constantp form) (compile-constant form target representation)) From ehuelsmann at common-lisp.net Thu Aug 13 13:15:02 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 13 Aug 2009 09:15:02 -0400 Subject: [armedbear-cvs] r12098 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 13 09:14:58 2009 New Revision: 12098 Log: Structure access referential integrity checks. Pointed out by piso. 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 Aug 13 09:14:58 2009 @@ -344,11 +344,13 @@ `(aref (truly-the ,',*dd-type* ,instance) ,,index)))) (t `((declaim (ftype (function * ,type) ,accessor-name)) - (defun ,accessor-name (instance) (structure-ref instance ,index)) + (defun ,accessor-name (instance) + (structure-ref (the ',*dd-name* instance) ,index)) (define-source-transform ,accessor-name (instance) ,(if (eq type 't) - ``(structure-ref ,instance ,,index) - ``(the ,',type (structure-ref ,instance ,,index))))))))) + ``(structure-ref (the ,',*dd-name* ,instance) ,,index) + ``(the ,',type + (structure-ref (the ,',*dd-name* ,instance) ,,index))))))))) (defun define-writer (slot) (let ((accessor-name (if *dd-conc-name* @@ -368,9 +370,10 @@ `(aset (truly-the ,',*dd-type* ,instance) ,,index ,value)))) (t `((defun (setf ,accessor-name) (value instance) - (structure-set instance ,index value)) + (structure-set (the ',*dd-name* instance) ,index value)) (define-source-transform (setf ,accessor-name) (value instance) - `(structure-set ,instance ,,index ,value))))))) + `(structure-set (the ,',*dd-name* ,instance) + ,,index ,value))))))) (defun define-access-functions () (let ((result ())) From ehuelsmann at common-lisp.net Thu Aug 13 13:17:07 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 13 Aug 2009 09:17:07 -0400 Subject: [armedbear-cvs] r12099 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 13 09:17:06 2009 New Revision: 12099 Log: Convert UNWIND-PROTECT block-nodes to UNWIND-PROTECT-NODEs. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.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 Thu Aug 13 09:17:06 2009 @@ -340,7 +340,7 @@ ;; ;; However, p1 transforms the forms being processed, so, we ;; need to copy the forms to create a second copy. - (let* ((block (make-block-node '(UNWIND-PROTECT))) + (let* ((block (make-unwind-protect-node :name '(UNWIND-PROTECT))) ;; a bit of jumping through hoops... (unwinding-forms (p1-body (copy-tree (cddr form)))) (unprotected-forms (p1-body (cddr form))) @@ -348,7 +348,7 @@ ;; protected by the UNWIND-PROTECT block (*blocks* (cons block *blocks*)) (protected-form (p1 (cadr form)))) - (setf (block-form block) + (setf (unwind-protect-form block) `(unwind-protect ,protected-form (progn , at unwinding-forms) , at unprotected-forms)) 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 Thu Aug 13 09:17:06 2009 @@ -7783,7 +7783,7 @@ (emit-move-from-stack target))) (defun p2-unwind-protect-node (block target) - (let ((form (block-form block))) + (let ((form (unwind-protect-form block))) (when (= (length form) 2) ; No cleanup form. (compile-form (second form) target nil) (return-from p2-unwind-protect-node)) From ehuelsmann at common-lisp.net Thu Aug 13 20:19:02 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 13 Aug 2009 16:19:02 -0400 Subject: [armedbear-cvs] r12100 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 13 16:18:59 2009 New Revision: 12100 Log: Move the NAME field from the NODE to the BLOCK-NODE; with the other node types, it's no longer required to distinguish nodes by the content of their NAME field. BLOCKs have NAMEs; CATCHes have TAGs. So, in the end, the NAME field belongs in the BLOCK-NODE. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Thu Aug 13 16:18:59 2009 @@ -340,7 +340,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 :name '(UNWIND-PROTECT))) + (let* ((block (make-unwind-protect-node)) ;; a bit of jumping through hoops... (unwinding-forms (p1-body (copy-tree (cddr form)))) (unprotected-forms (p1-body (cddr form))) @@ -368,7 +368,7 @@ ;; which is inside the block we're returning from, we'll do a non- ;; local return anyway so that UNWIND-PROTECT can catch it and run ;; its cleanup forms. - (dformat t "*blocks* = ~S~%" (mapcar #'node-name *blocks*)) + ;;(dformat t "*blocks* = ~S~%" (mapcar #'node-name *blocks*)) (let ((protected (enclosed-by-protected-block-p block))) (dformat t "p1-return-from protected = ~S~%" protected) (if protected @@ -385,7 +385,7 @@ (list* 'RETURN-FROM (cadr form) (mapcar #'p1 (cddr form)))) (defun p1-tagbody (form) - (let* ((block (make-tagbody-node :name '(TAGBODY))) + (let* ((block (make-tagbody-node)) (*blocks* (cons block *blocks*)) (*visible-tags* *visible-tags*) (local-tags '()) 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 Thu Aug 13 16:18:59 2009 @@ -837,7 +837,7 @@ (defknown single-valued-p (t) t) (defun single-valued-p (form) (cond ((node-p form) - (if (equal (node-name form) '(TAGBODY)) + (if (tagbody-node-p form) (not (unsafe-p (node-form form))) (single-valued-p (node-form form)))) ((var-ref-p form) @@ -6410,7 +6410,8 @@ t))))) ((node-p form) (let ((result t)) - (cond ((equal (node-name form) '(LET)) + (cond ((and (block-node-p form) + (equal (block-name form) '(LET))) ;; (format t "derive-type LET/LET* node case~%") (let* ((forms (cddr (node-form form))) (last-form (car (last forms))) @@ -6421,7 +6422,8 @@ ;; (format t "derived-type = ~S~%" derived-type) ;; ) (setf result derived-type))) - ((symbolp (node-name form)) + ((and (block-node-p form) + (symbolp (block-name form))) (unless (block-return-p form) (let* ((forms (cddr (block-form form))) (last-form (car (last forms))) 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 Thu Aug 13 16:18:59 2009 @@ -362,8 +362,6 @@ (defvar *hairy-arglist-p* nil) (defstruct node - ;; Block name or (TAGBODY) or (LET) or (MULTIPLE-VALUE-BIND). - name form (compiland *current-compiland*)) @@ -432,6 +430,8 @@ (defstruct (block-node (:conc-name block-) (:include control-transferring-node) (:constructor %make-block-node (name))) + ;; Block name or (TAGBODY) or (LET) or (MULTIPLE-VALUE-BIND). + name (exit (gensym)) target catch-tag @@ -456,7 +456,8 @@ (defun find-block (name) (dolist (block *blocks*) - (when (eq name (node-name block)) + (when (and (block-node-p block) + (eq name (block-name block))) (return block)))) (defknown node-constant-p (t) boolean) @@ -478,10 +479,10 @@ Non-local exits are required by blocks which do more in their cleanup than just restore the lastSpecialBinding (= dynamic environment). " - (let ((name (node-name object))) - (or (equal name '(CATCH)) - (equal name '(UNWIND-PROTECT)) - (equal name '(THREADS:SYNCHRONIZED-ON))))) + (or (unwind-protect-node-p object) + (catch-node-p object) + (and (block-node-p object) + (equal (block-name object) '(THREADS:SYNCHRONIZED-ON))))) (defknown enclosed-by-protected-block-p (&optional t) boolean) From ehuelsmann at common-lisp.net Thu Aug 13 20:51:46 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 13 Aug 2009 16:51:46 -0400 Subject: [armedbear-cvs] r12101 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 13 16:51:43 2009 New Revision: 12101 Log: Convert CATCH and SYNCHRONIZED-ON block-nodes to CATCH-NODEs and SYNCHRONIZED-NODEs respectively. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Thu Aug 13 16:51:43 2009 @@ -294,7 +294,7 @@ (defun p1-catch (form) (let* ((tag (p1 (cadr form))) (body (cddr form)) - (block (make-block-node '(CATCH))) + (block (make-catch-node)) ;; our subform processors need to know ;; they're enclosed in a CATCH block (*blocks* (cons block *blocks*)) @@ -311,13 +311,13 @@ (return-from p1-catch (car result))) (push tag result) (push 'CATCH result) - (setf (block-form block) result) + (setf (catch-form block) result) block)) (defun p1-threads-synchronized-on (form) (let* ((synchronized-object (p1 (cadr form))) (body (cddr form)) - (block (make-block-node '(THREADS:SYNCHRONIZED-ON))) + (block (make-synchronized-node)) (*blocks* (cons block *blocks*)) result) (dolist (subform body) @@ -325,7 +325,7 @@ (push (p1 subform) result) (when (memq op '(GO RETURN-FROM THROW)) (return)))) - (setf (block-form block) + (setf (synchronized-form block) (list* 'threads:synchronized-on synchronized-object (nreverse result))) block)) 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 Thu Aug 13 16:51:43 2009 @@ -7681,7 +7681,7 @@ (defknown p2-threads-synchronized-on (t t) t) (defun p2-threads-synchronized-on (block target) - (let* ((form (block-form block)) + (let* ((form (synchronized-form block)) (*register* *register*) (object-register (allocate-register)) (BEGIN-PROTECTED-RANGE (gensym)) @@ -7694,7 +7694,8 @@ (astore object-register) (emit 'monitorenter) (label BEGIN-PROTECTED-RANGE) - (compile-progn-body (cddr form) target) + (let ((*blocks* (cons block *blocks*))) + (compile-progn-body (cddr form) target)) (emit 'goto EXIT) (label END-PROTECTED-RANGE) (aload object-register) @@ -7712,7 +7713,7 @@ (defknown p2-catch-node (t t) t) (defun p2-catch-node (block target) - (let ((form (block-form block))) + (let ((form (catch-form block))) (when (= (length form) 2) ; (catch 'foo) (when target (emit-push-nil) @@ -7947,6 +7948,9 @@ (fix-boxing representation nil)) ((progv-node-p form) (p2-progv-node form target representation)) + ((synchronized-node-p form) + (p2-threads-synchronized-on form target) + (fix-boxing representation nil)) )) ((constantp form) (compile-constant form target representation)) 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 Thu Aug 13 16:51:43 2009 @@ -481,6 +481,7 @@ " (or (unwind-protect-node-p object) (catch-node-p object) + (synchronized-node-p object) (and (block-node-p object) (equal (block-name object) '(THREADS:SYNCHRONIZED-ON))))) From ehuelsmann at common-lisp.net Thu Aug 13 21:13:56 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 13 Aug 2009 17:13:56 -0400 Subject: [armedbear-cvs] r12102 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 13 17:13:54 2009 New Revision: 12102 Log: Convert PROGV block-nodes to PROGV-NODEs. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.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 Thu Aug 13 17:13:54 2009 @@ -779,7 +779,7 @@ (return-from p1-progv (p1 new-form)))) (let* ((symbols-form (p1 (cadr form))) (values-form (p1 (caddr form))) - (block (make-block-node '(PROGV))) + (block (make-progv-node)) (*blocks* (cons block *blocks*)) (body (cdddr form))) ;; The (commented out) block below means to detect compile-time @@ -790,9 +790,9 @@ ;; (dolist (name (second symbols-form)) ;; (let ((variable (make-variable :name name :special-p t))) ;; (push - (setf (block-form block) + (setf (progv-form block) `(progv ,symbols-form ,values-form ,@(p1-body body)) - (block-environment-register block) t) + (progv-environment-register block) t) block)) (defknown rewrite-progv (t) t) 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 Thu Aug 13 17:13:54 2009 @@ -4791,12 +4791,12 @@ (defun p2-progv-node (block target representation) (declare (ignore representation)) - (let* ((form (block-form block)) + (let* ((form (progv-form block)) (symbols-form (cadr form)) (values-form (caddr form)) (*register* *register*) (environment-register - (setf (block-environment-register block) (allocate-register))) + (setf (progv-environment-register block) (allocate-register))) (label-START (gensym))) (compile-form symbols-form 'stack nil) (compile-form values-form 'stack nil) @@ -7920,19 +7920,11 @@ ((eq name 'MULTIPLE-VALUE-BIND) (p2-m-v-b-node form target) (fix-boxing representation nil)) - ((eq name 'UNWIND-PROTECT) - (p2-unwind-protect-node form target) - (fix-boxing representation nil)) - ((eq name 'CATCH) - (p2-catch-node form target) - (fix-boxing representation nil)) ((eq name 'PROGV) (p2-progv-node form target representation)) ((eq name 'LOCALLY) (p2-locally-node form target representation)) - ((eq name 'THREADS:SYNCHRONIZED-ON) - (p2-threads-synchronized-on form target) - (fix-boxing representation nil))))))) + ))))) ((node-p form) (cond ((tagbody-node-p form) From ehuelsmann at common-lisp.net Fri Aug 14 20:08:22 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 14 Aug 2009 16:08:22 -0400 Subject: [armedbear-cvs] r12103 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 14 16:08:19 2009 New Revision: 12103 Log: Convert LOCALLY block-nodes to LOCALLY-NODEs. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.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 Aug 14 16:08:19 2009 @@ -238,14 +238,14 @@ (defun p1-locally (form) (let* ((*visible-variables* *visible-variables*) - (block (make-block-node '(LOCALLY))) + (block (make-locally-node)) (free-specials (process-declarations-for-vars (cdr form) nil block))) - (setf (block-free-specials block) free-specials) + (setf (locally-free-specials block) free-specials) (dolist (special free-specials) ;; (format t "p1-locally ~S is special~%" name) (push special *visible-variables*)) (let ((*blocks* (cons block *blocks*))) - (setf (block-form block) + (setf (locally-form block) (list* 'LOCALLY (p1-body (cdr form)))) block))) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 14 16:08:19 2009 @@ -4439,8 +4439,8 @@ (defknown p2-locally-node (t t t) t) (defun p2-locally-node (block target representation) (with-saved-compiler-policy - (let* ((body (cdr (block-form block))) - (*visible-variables* (append (block-free-specials block) + (let* ((body (cdr (locally-form block))) + (*visible-variables* (append (locally-free-specials block) *visible-variables*)) (*blocks* (cons block *blocks*))) (process-optimization-declarations body) @@ -7920,10 +7920,6 @@ ((eq name 'MULTIPLE-VALUE-BIND) (p2-m-v-b-node form target) (fix-boxing representation nil)) - ((eq name 'PROGV) - (p2-progv-node form target representation)) - ((eq name 'LOCALLY) - (p2-locally-node form target representation)) ))))) ((node-p form) (cond From ehuelsmann at common-lisp.net Fri Aug 14 21:08:08 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 14 Aug 2009 17:08:08 -0400 Subject: [armedbear-cvs] r12104 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 14 17:08:05 2009 New Revision: 12104 Log: Switch MULTIPLE-VALUE-BIND block-nodes to M-V-B-NODEs. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.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 Aug 14 17:08:05 2009 @@ -255,14 +255,13 @@ (let ((new-form `(let* ((,(caadr form) ,(caddr form))) ,@(cdddr form)))) (return-from p1-m-v-b (p1-let/let* new-form)))) (let* ((*visible-variables* *visible-variables*) - (block (make-block-node '(MULTIPLE-VALUE-BIND))) - (*blocks* (cons block *blocks*)) + (block (make-m-v-b-node)) (varlist (cadr form)) - (values-form (caddr form)) + ;; Process the values-form first. ("The scopes of the name binding and + ;; declarations do not include the values-form.") + (values-form (p1 (caddr form))) + (*blocks* (cons block *blocks*)) (body (cdddr form))) - ;; Process the values-form first. ("The scopes of the name binding and - ;; declarations do not include the values-form.") - (setf values-form (p1 values-form)) (let ((vars ())) (dolist (symbol varlist) (let ((var (make-variable :name symbol :block block))) @@ -273,14 +272,14 @@ (dolist (variable vars) (when (special-variable-p (variable-name variable)) (setf (variable-special-p variable) t - (block-environment-register block) t))) - (setf (block-free-specials block) + (m-v-b-environment-register block) t))) + (setf (m-v-b-free-specials block) (process-declarations-for-vars body vars block)) - (dolist (special (block-free-specials block)) + (dolist (special (m-v-b-free-specials block)) (push special *visible-variables*)) - (setf (block-vars block) (nreverse vars))) + (setf (m-v-b-vars block) (nreverse vars))) (setf body (p1-body body)) - (setf (block-form block) + (setf (m-v-b-form block) (list* 'MULTIPLE-VALUE-BIND varlist values-form body)) block)) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 14 17:08:05 2009 @@ -3987,13 +3987,12 @@ :catch-type 0) *handlers*))) (defun p2-m-v-b-node (block target) - (let* ((*blocks* (cons block *blocks*)) - (*register* *register*) - (form (block-form block)) + (let* ((*register* *register*) + (form (m-v-b-form block)) (*visible-variables* *visible-variables*) (vars (second form)) (bind-special-p nil) - (variables (block-vars block)) + (variables (m-v-b-vars block)) (label-START (gensym))) (dolist (variable variables) (let ((special-p (variable-special-p variable))) @@ -4006,8 +4005,8 @@ (when bind-special-p (dformat t "p2-m-v-b-node lastSpecialBinding~%") ;; Save current dynamic environment. - (setf (block-environment-register block) (allocate-register)) - (save-dynamic-environment (block-environment-register block)) + (setf (m-v-b-environment-register block) (allocate-register)) + (save-dynamic-environment (m-v-b-environment-register block)) (label label-START)) ;; Make sure there are no leftover values from previous calls. (emit-clear-values) @@ -4062,10 +4061,11 @@ ;; Make the variables visible for the body forms. (dolist (variable variables) (push variable *visible-variables*)) - (dolist (variable (block-free-specials block)) + (dolist (variable (m-v-b-free-specials block)) (push variable *visible-variables*)) ;; Body. - (compile-progn-body (cdddr form) target) + (let ((*blocks* (cons block *blocks*))) + (compile-progn-body (cdddr form) target)) (when bind-special-p (restore-environment-and-make-handler (block-environment-register block) label-START)))) @@ -7917,9 +7917,6 @@ (p2-flet-node form target representation)) ((eq name 'LABELS) (p2-labels-node form target representation)) - ((eq name 'MULTIPLE-VALUE-BIND) - (p2-m-v-b-node form target) - (fix-boxing representation nil)) ))))) ((node-p form) (cond @@ -7929,6 +7926,9 @@ ((unwind-protect-node-p form) (p2-unwind-protect-node form target) (fix-boxing representation nil)) + ((m-v-b-node-p form) + (p2-m-v-b-node form target) + (fix-boxing representation nil)) ((locally-node-p form) (p2-locally-node form target representation)) ((catch-node-p form) @@ -7939,6 +7939,8 @@ ((synchronized-node-p form) (p2-threads-synchronized-on form target) (fix-boxing representation nil)) + (t + (aver (not "Can't happen"))) )) ((constantp form) (compile-constant form target representation)) From mevenson at common-lisp.net Wed Aug 19 14:51:59 2009 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 19 Aug 2009 10:51:59 -0400 Subject: [armedbear-cvs] r12105 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Aug 19 10:51:56 2009 New Revision: 12105 Log: Split StackFrame abstraction into Java and Lisp stack frames. >From the original patch/idea from Tobias Rittweiler this introduces more information of primary interest to ABCL implemnters such as when a form like (make-thread #'(lambda ())) is evaluated All users of EXT:BACKTRACE-AS-LIST should now use SYS:BACKTRACE, the results of which is a list of the new builtin classes JAVA_STACK_FRAME or LISP_STACK_FRAME. The methods SYS:FRAME-TO-STRING and SYS:FRAME-TO-LIST are defined to break these new objects into inspectable parts. As a convenience, there is a SYS:BACKTRACE-AS-LIST which calls SYS:FRAME-TO-LIST to each element of the computed backtrace. Refactorings have occurred on the Java side: the misnamed LispThread.backtrace() is now LispThread.printBacktrace(). LispThread.backtraceAsList() is now LispThread.backtrace() as it is a shorter name, and more to the point. Java stack frames only appear after a call through Lisp.error(), which has only the top level as a restart as an option. Added: trunk/abcl/src/org/armedbear/lisp/JavaStackFrame.java (contents, props changed) trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java (contents, props changed) trunk/abcl/src/org/armedbear/lisp/StackFrame.java (contents, props changed) Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java trunk/abcl/src/org/armedbear/lisp/Interpreter.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/LispThread.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/boot.lisp trunk/abcl/src/org/armedbear/lisp/debug.lisp trunk/abcl/src/org/armedbear/lisp/signal.lisp trunk/abcl/src/org/armedbear/lisp/top-level.lisp 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 Wed Aug 19 10:51:56 2009 @@ -142,6 +142,10 @@ public static final BuiltInClass THREAD = addClass(Symbol.THREAD); public static final BuiltInClass TWO_WAY_STREAM = addClass(Symbol.TWO_WAY_STREAM); public static final BuiltInClass VECTOR = addClass(Symbol.VECTOR); + public static final BuiltInClass STACK_FRAME = addClass(Symbol.STACK_FRAME); + public static final BuiltInClass LISP_STACK_FRAME = addClass(Symbol.LISP_STACK_FRAME); + public static final BuiltInClass JAVA_STACK_FRAME = addClass(Symbol.JAVA_STACK_FRAME); + public static final StructureClass STRUCTURE_OBJECT = new StructureClass(Symbol.STRUCTURE_OBJECT, list(CLASS_T)); @@ -275,6 +279,12 @@ TWO_WAY_STREAM.setCPL(TWO_WAY_STREAM, STREAM, CLASS_T); VECTOR.setDirectSuperclasses(list(ARRAY, SEQUENCE)); VECTOR.setCPL(VECTOR, ARRAY, SEQUENCE, CLASS_T); + STACK_FRAME.setDirectSuperclasses(CLASS_T); + STACK_FRAME.setCPL(STACK_FRAME, CLASS_T); + LISP_STACK_FRAME.setDirectSuperclasses(STACK_FRAME); + LISP_STACK_FRAME.setCPL(LISP_STACK_FRAME, STACK_FRAME, CLASS_T); + JAVA_STACK_FRAME.setDirectSuperclasses(STACK_FRAME); + JAVA_STACK_FRAME.setCPL(JAVA_STACK_FRAME, STACK_FRAME, CLASS_T); } static 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 Wed Aug 19 10:51:56 2009 @@ -389,7 +389,7 @@ catch (Throwable t) { getStandardInput().clearInput(); out.printStackTrace(t); - thread.backtrace(); + thread.printBacktrace(); } } } @@ -408,7 +408,7 @@ out._writeLine("Error: unhandled condition: " + condition.writeToString()); if (thread != null) - thread.backtrace(); + thread.printBacktrace(); } catch (Throwable t) { Added: trunk/abcl/src/org/armedbear/lisp/JavaStackFrame.java ============================================================================== --- (empty file) +++ trunk/abcl/src/org/armedbear/lisp/JavaStackFrame.java Wed Aug 19 10:51:56 2009 @@ -0,0 +1,133 @@ +/* + * JavaStackFrame.java + * + * Copyright (C) 2009 Mark Evenson + * $Id$ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class JavaStackFrame + extends StackFrame +{ + public final StackTraceElement javaFrame; + + public JavaStackFrame(StackTraceElement javaFrame) + { + this.javaFrame = javaFrame; + } + + @Override + public LispObject typeOf() { + return Symbol.JAVA_STACK_FRAME; + } + + @Override + public LispObject classOf() { return BuiltInClass.JAVA_STACK_FRAME; } + + @Override + public String writeToString() { + String result = null; + final String JAVA_STACK_FRAME = "JAVA-STACK-FRAME"; + try { + result = unreadableString(JAVA_STACK_FRAME + " " + + toLispString().toString()); + } catch (ConditionThrowable t) { + Debug.trace("Implementation error: "); + Debug.trace(t); + result = unreadableString(JAVA_STACK_FRAME); + } + return result; + } + + @Override + public LispObject typep(LispObject typeSpecifier) + throws ConditionThrowable + { + if (typeSpecifier == Symbol.JAVA_STACK_FRAME) + return T; + if (typeSpecifier == BuiltInClass.JAVA_STACK_FRAME) + return T; + return super.typep(typeSpecifier); + } + + static final Symbol CLASS = Packages.internKeyword("CLASS"); + static final Symbol METHOD = Packages.internKeyword("METHOD"); + static final Symbol FILE = Packages.internKeyword("FILE"); + static final Symbol LINE = Packages.internKeyword("LINE"); + static final Symbol NATIVE_METHOD = Packages.internKeyword("NATIVE-METHOD"); + + public LispObject toLispList() throws ConditionThrowable + { + LispObject result = Lisp.NIL; + + if ( javaFrame == null) + return result; + + result = result.push(CLASS); + result = result.push(new SimpleString(javaFrame.getClassName())); + result = result.push(METHOD); + result = result.push(new SimpleString(javaFrame.getMethodName())); + result = result.push(FILE); + result = result.push(new SimpleString(javaFrame.getFileName())); + result = result.push(LINE); + result = result.push(Fixnum.getInstance(javaFrame.getLineNumber())); + if (javaFrame.isNativeMethod()) { + result = result.push(NATIVE_METHOD); + result = result.push(Symbol.T); + } + + return result.nreverse(); + } + + @Override + public SimpleString toLispString() + throws ConditionThrowable + { + return new SimpleString(javaFrame.toString()); + } + + @Override + public LispObject getParts() + throws ConditionThrowable + { + LispObject result = NIL; + result = result.push(new Cons("CLASS", + new SimpleString(javaFrame.getClassName()))); + result = result.push(new Cons("METHOD", + new SimpleString(javaFrame.getMethodName()))); + result = result.push(new Cons("FILE", + new SimpleString(javaFrame.getFileName()))); + result = result.push(new Cons("LINE", + Fixnum.getInstance(javaFrame.getLineNumber()))); + result = result.push(new Cons("NATIVE-METHOD", + LispObject.getInstance(javaFrame.isNativeMethod()))); + return result.nreverse(); + } +} 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 Wed Aug 19 10:51:56 2009 @@ -271,7 +271,7 @@ catch (StackOverflowError e) { thread.setSpecialVariable(_SAVED_BACKTRACE_, - thread.backtraceAsList(0)); + thread.backtrace(0)); return error(new StorageCondition("Stack overflow.")); } catch (Go go) @@ -287,7 +287,7 @@ { Debug.trace(t); thread.setSpecialVariable(_SAVED_BACKTRACE_, - thread.backtraceAsList(0)); + thread.backtrace(0)); return error(new LispError("Caught " + t + ".")); } Debug.assertTrue(result != null); @@ -320,15 +320,39 @@ } }; + private static final void pushJavaStackFrames() throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + final StackTraceElement[] frames = thread.getJavaStackTrace(); + + // Search for last Primitive in the StackTrace; that was the + // last entry point from Lisp. + int last = frames.length - 1; + for (int i = 0; i<= last; i++) { + if (frames[i].getClassName().startsWith("org.armedbear.lisp.Primitive")) + last = i; + } + // Do not include the first three frames: + // Thread.getStackTrace, LispThread.getJavaStackTrace, + // Lisp.pushJavaStackFrames. + while (last > 2) { + thread.pushStackFrame(new JavaStackFrame(frames[last])); + last--; + } + } + + public static final LispObject error(LispObject condition) throws ConditionThrowable { + pushJavaStackFrames(); return Symbol.ERROR.execute(condition); } public static final LispObject error(LispObject condition, LispObject message) throws ConditionThrowable { + pushJavaStackFrames(); return Symbol.ERROR.execute(condition, Keyword.FORMAT_CONTROL, message); } @@ -852,6 +876,14 @@ type_error(obj, Symbol.SINGLE_FLOAT); } + public static final StackFrame checkStackFrame(LispObject obj) + throws ConditionThrowable + { + if (obj instanceof StackFrame) + return (StackFrame) obj; + return (StackFrame)// Not reached. + type_error(obj, Symbol.STACK_FRAME); + } static { Added: trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java ============================================================================== --- (empty file) +++ trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java Wed Aug 19 10:51:56 2009 @@ -0,0 +1,193 @@ +/* + * LispStackFrame.java + * + * Copyright (C) 2009 Mark Evenson + * $Id$ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class LispStackFrame + extends StackFrame +{ + public final LispObject operator; + private final LispObject first; + private final LispObject second; + private final LispObject third; + private final LispObject[] args; + + public LispStackFrame(LispObject operator) + { + this.operator = operator; + first = null; + second = null; + third = null; + args = null; + } + + public LispStackFrame(LispObject operator, LispObject arg) + { + this.operator = operator; + first = arg; + second = null; + third = null; + args = null; + } + + public LispStackFrame(LispObject operator, LispObject first, + LispObject second) + { + this.operator = operator; + this.first = first; + this.second = second; + third = null; + args = null; + } + + public LispStackFrame(LispObject operator, LispObject first, + LispObject second, LispObject third) + + { + this.operator = operator; + this.first = first; + this.second = second; + this.third = third; + args = null; + } + + public LispStackFrame(LispObject operator, LispObject... args) + { + this.operator = operator; + first = null; + second = null; + third = null; + final int length = args.length; + this.args = new LispObject[length]; + System.arraycopy(args, 0, this.args, 0, length); + } + + @Override + public LispObject typeOf() { + return Symbol.LISP_STACK_FRAME; + } + + @Override + public LispObject classOf() { + return BuiltInClass.LISP_STACK_FRAME; + } + + @Override + public String writeToString() + { + String result = ""; + final String LISP_STACK_FRAME = "LISP-STACK-FRAME"; + try { + result = unreadableString(LISP_STACK_FRAME + " " + + toLispString().getStringValue()); + } catch (ConditionThrowable t) { + Debug.trace("Implementation error: "); + Debug.trace(t); + result = unreadableString(LISP_STACK_FRAME); + } + return result; + } + + @Override + public LispObject typep(LispObject typeSpecifier) + throws ConditionThrowable + { + if (typeSpecifier == Symbol.LISP_STACK_FRAME) + return T; + if (typeSpecifier == BuiltInClass.LISP_STACK_FRAME) + return T; + return super.typep(typeSpecifier); + } + + public LispObject toLispList() + throws ConditionThrowable + { + LispObject result = argsToLispList(); + if (operator instanceof Operator) { + LispObject lambdaName = ((Operator)operator).getLambdaName(); + if (lambdaName != null && lambdaName != Lisp.NIL) + return result.push(lambdaName); + } + return result.push(operator); + } + + private LispObject argsToLispList() + throws ConditionThrowable + { + LispObject result = Lisp.NIL; + if (args != null) { + for (int i = 0; i < args.length; i++) + result = result.push(args[i]); + } else { + do { + if (first != null) + result = result.push(first); + else + break; + if (second != null) + result = result.push(second); + else + break; + if (third != null) + result = result.push(third); + else + break; + } while (false); + } + return result.nreverse(); + } + + public SimpleString toLispString() + throws ConditionThrowable + { + return new SimpleString(toLispList().writeToString()); + } + + public LispObject getOperator() { + return operator; + } + + @Override + public LispObject getParts() + throws ConditionThrowable + { + LispObject result = NIL; + result = result.push(new Cons("OPERATOR", getOperator())); + LispObject args = argsToLispList(); + if (args != NIL) { + result = result.push(new Cons("ARGS", args)); + } + + return result.nreverse(); + } +} 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 Aug 19 10:51:56 2009 @@ -117,6 +117,10 @@ javaThread.start(); } + public StackTraceElement[] getJavaStackTrace() { + return javaThread.getStackTrace(); + } + @Override public LispObject typeOf() { @@ -447,98 +451,6 @@ tag.writeToString() + ".")); } - private static class StackFrame - { - public final LispObject operator; - private final LispObject first; - private final LispObject second; - private final LispObject third; - private final LispObject[] args; - final StackFrame next; - - public StackFrame(LispObject operator, StackFrame next) - { - this.operator = operator; - first = null; - second = null; - third = null; - args = null; - this.next = next; - } - - public StackFrame(LispObject operator, LispObject arg, StackFrame next) - { - this.operator = operator; - first = arg; - second = null; - third = null; - args = null; - this.next = next; - } - - public StackFrame(LispObject operator, LispObject first, - LispObject second, StackFrame next) - { - this.operator = operator; - this.first = first; - this.second = second; - third = null; - args = null; - this.next = next; - } - - public StackFrame(LispObject operator, LispObject first, - LispObject second, LispObject third, StackFrame next) - { - this.operator = operator; - this.first = first; - this.second = second; - this.third = third; - args = null; - this.next = next; - } - - public StackFrame(LispObject operator, LispObject[] args, StackFrame next) - { - this.operator = operator; - first = null; - second = null; - third = null; - this.args = args; - this.next = next; - } - - public LispObject toList() throws ConditionThrowable - { - LispObject list = NIL; - if (args != null) { - for (int i = 0; i < args.length; i++) - list = list.push(args[i]); - } else { - do { - if (first != null) - list = list.push(first); - else - break; - if (second != null) - list = list.push(second); - else - break; - if (third != null) - list = list.push(third); - else - break; - } while (false); - } - list = list.nreverse(); - if (operator instanceof Operator) { - LispObject lambdaName = ((Operator)operator).getLambdaName(); - if (lambdaName != null && lambdaName != NIL) - return list.push(lambdaName); - } - return list.push(operator); - } - } private StackFrame stack = null; @@ -553,42 +465,18 @@ { } - public final void pushStackFrame(LispObject operator) - throws ConditionThrowable - { - stack = new StackFrame(operator, stack); - } - - public final void pushStackFrame(LispObject operator, LispObject arg) - throws ConditionThrowable - { - stack = new StackFrame(operator, arg, stack); - } - - public final void pushStackFrame(LispObject operator, LispObject first, - LispObject second) - throws ConditionThrowable + public final void pushStackFrame(StackFrame frame) + throws ConditionThrowable { - stack = new StackFrame(operator, first, second, stack); + frame.setNext(stack); + stack = frame; } - public final void pushStackFrame(LispObject operator, LispObject first, - LispObject second, LispObject third) - throws ConditionThrowable - { - stack = new StackFrame(operator, first, second, third, stack); - } - - public final void pushStackFrame(LispObject operator, LispObject... args) - throws ConditionThrowable - { - stack = new StackFrame(operator, args, stack); - } public final void popStackFrame() { if (stack != null) - stack = stack.next; + stack = stack.getNext(); } public void resetStack() @@ -602,7 +490,7 @@ if (use_fast_calls) return function.execute(); - pushStackFrame(function); + pushStackFrame(new LispStackFrame(function)); try { return function.execute(); } @@ -618,7 +506,7 @@ if (use_fast_calls) return function.execute(arg); - pushStackFrame(function, arg); + pushStackFrame(new LispStackFrame(function, arg)); try { return function.execute(arg); } @@ -635,7 +523,7 @@ if (use_fast_calls) return function.execute(first, second); - pushStackFrame(function, first, second); + pushStackFrame(new LispStackFrame(function, first, second)); try { return function.execute(first, second); } @@ -652,7 +540,7 @@ if (use_fast_calls) return function.execute(first, second, third); - pushStackFrame(function, first, second, third); + pushStackFrame(new LispStackFrame(function, first, second, third)); try { return function.execute(first, second, third); } @@ -670,7 +558,7 @@ if (use_fast_calls) return function.execute(first, second, third, fourth); - pushStackFrame(function, first, second, third, fourth); + pushStackFrame(new LispStackFrame(function, first, second, third, fourth)); try { return function.execute(first, second, third, fourth); } @@ -688,7 +576,7 @@ if (use_fast_calls) return function.execute(first, second, third, fourth, fifth); - pushStackFrame(function, first, second, third, fourth, fifth); + pushStackFrame(new LispStackFrame(function, first, second, third, fourth, fifth)); try { return function.execute(first, second, third, fourth, fifth); } @@ -707,7 +595,8 @@ if (use_fast_calls) return function.execute(first, second, third, fourth, fifth, sixth); - pushStackFrame(function, first, second, third, fourth, fifth, sixth); + pushStackFrame(new LispStackFrame(function, first, second, + third, fourth, fifth, sixth)); try { return function.execute(first, second, third, fourth, fifth, sixth); } @@ -727,8 +616,8 @@ return function.execute(first, second, third, fourth, fifth, sixth, seventh); - pushStackFrame(function, first, second, third, fourth, fifth, sixth, - seventh); + pushStackFrame(new LispStackFrame(function, first, second, third, + fourth, fifth, sixth, seventh)); try { return function.execute(first, second, third, fourth, fifth, sixth, seventh); @@ -749,8 +638,8 @@ return function.execute(first, second, third, fourth, fifth, sixth, seventh, eighth); - pushStackFrame(function, first, second, third, fourth, fifth, sixth, - seventh, eighth); + pushStackFrame(new LispStackFrame(function, first, second, third, + fourth, fifth, sixth, seventh, eighth)); try { return function.execute(first, second, third, fourth, fifth, sixth, seventh, eighth); @@ -766,7 +655,7 @@ if (use_fast_calls) return function.execute(args); - pushStackFrame(function, args); + pushStackFrame(new LispStackFrame(function, args)); try { return function.execute(args); } @@ -775,12 +664,12 @@ } } - public void backtrace() + public void printBacktrace() { - backtrace(0); + printBacktrace(0); } - public void backtrace(int limit) + public void printBacktrace(int limit) { if (stack != null) { try { @@ -796,7 +685,7 @@ out._writeString(String.valueOf(count)); out._writeString(": "); - pprint(s.toList(), out.getCharPos(), out); + pprint(s.toLispList(), out.getCharPos(), out); out.terpri(); out._finishOutput(); if (limit > 0 && ++count == limit) @@ -810,7 +699,7 @@ } } - public LispObject backtraceAsList(int limit) throws ConditionThrowable + public LispObject backtrace(int limit) throws ConditionThrowable { LispObject result = NIL; if (stack != null) { @@ -818,10 +707,10 @@ try { StackFrame s = stack; while (s != null) { - result = result.push(s.toList()); + result = result.push(s); if (limit > 0 && ++count == limit) break; - s = s.next; + s = s.getNext(); } } catch (Throwable t) { @@ -838,19 +727,23 @@ for (int i = 0; i < 8; i++) { if (s == null) break; - LispObject operator = s.operator; - if (operator != null) { - operator.incrementHotCount(); - operator.incrementCallCount(); - } - s = s.next; + if (s instanceof LispStackFrame) { + LispObject operator = ((LispStackFrame)s).getOperator(); + if (operator != null) { + operator.incrementHotCount(); + operator.incrementCallCount(); + } + s = s.getNext(); + } } while (s != null) { - LispObject operator = s.operator; - if (operator != null) - operator.incrementCallCount(); - s = s.next; + if (s instanceof LispStackFrame) { + LispObject operator = ((LispStackFrame)s).getOperator(); + if (operator != null) + operator.incrementCallCount(); + } + s = s.getNext(); } } @@ -1110,10 +1003,10 @@ } }; - // ### backtrace-as-list - private static final Primitive BACKTRACE_AS_LIST = - new Primitive("backtrace-as-list", PACKAGE_EXT, true, "", - "Returns a backtrace of the invoking thread as a list.") + // ### backtrace + private static final Primitive BACKTRACE = + new Primitive("backtrace", PACKAGE_SYS, true, "", + "Returns a backtrace of the invoking thread.") { @Override public LispObject execute(LispObject[] args) @@ -1122,9 +1015,39 @@ if (args.length > 1) return error(new WrongNumberOfArgumentsException(this)); int limit = args.length > 0 ? Fixnum.getValue(args[0]) : 0; - return currentThread().backtraceAsList(limit); + return currentThread().backtrace(limit); } }; + // ### frame-to-string + private static final Primitive FRAME_TO_STRING = + new Primitive("frame-to-string", PACKAGE_SYS, true, "frame") + { + @Override + public LispObject execute(LispObject[] args) + throws ConditionThrowable + { + if (args.length != 1) + return error(new WrongNumberOfArgumentsException(this)); + + return checkStackFrame(args[0]).toLispString(); + } + }; + + // ### frame-to-list + private static final Primitive FRAME_TO_LIST = + new Primitive("frame-to-list", PACKAGE_SYS, true, "frame") + { + @Override + public LispObject execute(LispObject[] args) + throws ConditionThrowable + { + if (args.length != 1) + return error(new WrongNumberOfArgumentsException(this)); + + return checkStackFrame(args[0]).toLispList(); + } + }; + static { //FIXME: this block has been added for pre-0.16 compatibility Added: trunk/abcl/src/org/armedbear/lisp/StackFrame.java ============================================================================== --- (empty file) +++ trunk/abcl/src/org/armedbear/lisp/StackFrame.java Wed Aug 19 10:51:56 2009 @@ -0,0 +1,61 @@ +/* + * StackFrame.java + * + * Copyright (C) 2009 Mark Evenson + * $Id$ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public abstract class StackFrame + extends LispObject +{ + @Override + public LispObject typep(LispObject typeSpecifier) + throws ConditionThrowable + { + if (typeSpecifier == Symbol.STACK_FRAME) + return T; + if (typeSpecifier == BuiltInClass.STACK_FRAME) + return T; + return super.typep(typeSpecifier); + } + + StackFrame next; + + void setNext(StackFrame nextFrame) { + this.next = nextFrame; + } + StackFrame getNext() { + return this.next; + } + + public abstract LispObject toLispList() throws ConditionThrowable; + public abstract SimpleString toLispString() throws ConditionThrowable; +} 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 Aug 19 10:51:56 2009 @@ -3039,6 +3039,12 @@ PACKAGE_SYS.addInternalSymbol("STRING-INPUT-STREAM"); public static final Symbol STRING_OUTPUT_STREAM = PACKAGE_SYS.addInternalSymbol("STRING-OUTPUT-STREAM"); + public static final Symbol STACK_FRAME = + PACKAGE_SYS.addInternalSymbol("STACK-FRAME"); + public static final Symbol LISP_STACK_FRAME = + PACKAGE_SYS.addInternalSymbol("LISP-STACK-FRAME"); + public static final Symbol JAVA_STACK_FRAME = + PACKAGE_SYS.addInternalSymbol("JAVA-STACK-FRAME"); // CDR6 public static final Symbol _INSPECTOR_HOOK_ = 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 Wed Aug 19 10:51:56 2009 @@ -334,7 +334,6 @@ (load-system-file "defsetf") (load-system-file "package") - (defun preload-package (pkg) (%format t "Preloading ~S~%" (find-package pkg)) (dolist (sym (package-symbols pkg)) Modified: trunk/abcl/src/org/armedbear/lisp/debug.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/debug.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/debug.lisp Wed Aug 19 10:51:56 2009 @@ -100,7 +100,7 @@ (simple-format *debug-io* " ~A~%" condition))))) (defun invoke-debugger (condition) - (let ((*saved-backtrace* (backtrace-as-list))) + (let ((*saved-backtrace* (sys:backtrace))) (when *debugger-hook* (let ((hook-function *debugger-hook*) (*debugger-hook* nil)) @@ -129,3 +129,7 @@ (list :format-control format-control :format-arguments format-arguments)))) nil)) + +(defun backtrace-as-list (&optional (n 0)) + "Return BACKTRACE with each element converted to a list." + (mapcar #'sys::frame-to-list (sys:backtrace n))) Modified: trunk/abcl/src/org/armedbear/lisp/signal.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/signal.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/signal.lisp Wed Aug 19 10:51:56 2009 @@ -49,7 +49,7 @@ (let* ((old-bos *break-on-signals*) (*break-on-signals* nil)) (when (typep condition old-bos) - (let ((*saved-backtrace* (backtrace-as-list))) + (let ((*saved-backtrace* (sys:backtrace))) (break "~A~%BREAK called because of *BREAK-ON-SIGNALS* (now rebound to NIL)." condition)))) (loop Modified: trunk/abcl/src/org/armedbear/lisp/top-level.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/top-level.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/top-level.lisp Wed Aug 19 10:51:56 2009 @@ -102,6 +102,23 @@ (%format *debug-io* "~A~%" s)) (show-restarts (compute-restarts) *debug-io*))) +(defun print-frame (frame stream &key prefix) + (when prefix + (write-string prefix stream)) + (etypecase frame + (sys::lisp-stack-frame + (pprint-logical-block (stream nil :prefix "(" :suffix ")") + (setq frame (sys:frame-to-list frame)) + (ignore-errors + (prin1 (car frame) stream) + (let ((args (cdr frame))) + (if (listp args) + (format stream "~{ ~_~S~}" args) + (format stream " ~S" args)))))) + (sys::java-stack-frame + (write-string (sys:frame-to-string frame) stream)))) + + (defun backtrace-command (args) (let ((count (or (and args (ignore-errors (parse-integer args))) 8)) @@ -113,14 +130,7 @@ (*print-array* nil)) (dolist (frame *saved-backtrace*) (fresh-line *debug-io*) - (let ((prefix (format nil "~3D: (" n))) - (pprint-logical-block (*debug-io* nil :prefix prefix :suffix ")") - (ignore-errors - (prin1 (car frame) *debug-io*) - (let ((args (cdr frame))) - (if (listp args) - (format *debug-io* "~{ ~_~S~}" args) - (format *debug-io* " ~S" args)))))) + (print-frame frame *debug-io* :prefix (format nil "~3D: " n)) (incf n) (when (>= n count) (return)))))) @@ -136,12 +146,7 @@ (*print-readably* nil) (*print-structure* nil)) (fresh-line *debug-io*) - (pprint-logical-block (*debug-io* nil :prefix "(" :suffix ")") - (prin1 (car frame) *debug-io*) - (let ((args (cdr frame))) - (if (listp args) - (format *debug-io* "~{ ~_~S~}" args) - (format *debug-io* " ~S" args)))))) + (print-frame frame *debug-io*))) (setf *** ** ** * * frame))) From mevenson at common-lisp.net Wed Aug 19 16:30:30 2009 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 19 Aug 2009 12:30:30 -0400 Subject: [armedbear-cvs] r12106 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Aug 19 12:30:27 2009 New Revision: 12106 Log: Optimization: copy reference to args in LispStackFrame constructor. Modified: trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java Modified: trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java Wed Aug 19 12:30:27 2009 @@ -87,9 +87,7 @@ first = null; second = null; third = null; - final int length = args.length; - this.args = new LispObject[length]; - System.arraycopy(args, 0, this.args, 0, length); + this.args = args; } @Override From ehuelsmann at common-lisp.net Wed Aug 19 21:17:30 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 19 Aug 2009 17:17:30 -0400 Subject: [armedbear-cvs] r12107 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Aug 19 17:17:28 2009 New Revision: 12107 Log: Check simple (symbolp) types in compiled code when *safety* is 1 or 2. Note: *safety* 3 checks full types; 0 skips checks. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Wed Aug 19 17:17:28 2009 @@ -855,6 +855,13 @@ (require-type ,sym ',type) ,sym))) (p1 new-expr))) + ((and (<= 1 *safety* 2) ;; at safety 1 or 2 check relatively + (symbolp type)) ;; simple types (those specified by a single symbol) + (let* ((sym (gensym)) + (new-expr `(let ((,sym ,expr)) + (require-type ,sym ',type) + ,sym))) + (p1 new-expr))) (t (list 'THE type (p1 expr)))))) From ehuelsmann at common-lisp.net Wed Aug 19 22:09:14 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 19 Aug 2009 18:09:14 -0400 Subject: [armedbear-cvs] r12108 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Aug 19 18:09:11 2009 New Revision: 12108 Log: r12104 followup: forgotten M-V-B-NODE accessor. 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 Wed Aug 19 18:09:11 2009 @@ -4067,7 +4067,7 @@ (let ((*blocks* (cons block *blocks*))) (compile-progn-body (cdddr form) target)) (when bind-special-p - (restore-environment-and-make-handler (block-environment-register block) + (restore-environment-and-make-handler (m-v-b-environment-register block) label-START)))) (defun propagate-vars (block) From ehuelsmann at common-lisp.net Sun Aug 23 08:31:22 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 23 Aug 2009 04:31:22 -0400 Subject: [armedbear-cvs] r12109 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 23 04:31:19 2009 New Revision: 12109 Log: Remove references to the long-deleted Native class. Modified: trunk/abcl/src/org/armedbear/lisp/Time.java Modified: trunk/abcl/src/org/armedbear/lisp/Time.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Time.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Time.java Sun Aug 23 04:31:19 2009 @@ -39,33 +39,6 @@ public final class Time extends Lisp { - private static final long getCurrentThreadUserTime() - { - try - { - Class c = Class.forName("org.armedbear.lisp.Native"); - Method m = c.getMethod("getCurrentThreadUserTime", (Class[]) null); - Object result = m.invoke((Object) null, (Object[]) null); - if (result instanceof Long) - return ((Long)result).longValue(); - } - catch (Throwable t) {} - return -1; - } - - private static final long getCurrentThreadSystemTime() - { - try - { - Class c = Class.forName("org.armedbear.lisp.Native"); - Method m = c.getMethod("getCurrentThreadSystemTime", (Class[]) null); - Object result = m.invoke((Object) null, (Object[]) null); - if (result instanceof Long) - return ((Long)result).longValue(); - } - catch (Throwable t) {} - return -1; - } // ### %time private static final Primitive _TIME = @@ -75,14 +48,6 @@ public LispObject execute(LispObject arg) throws ConditionThrowable { Cons.setCount(0); - long userStart = -1; - long systemStart = -1; - try - { - userStart = getCurrentThreadUserTime(); - systemStart = getCurrentThreadSystemTime(); - } - catch (Throwable t) {} long realStart = System.currentTimeMillis(); try { @@ -91,18 +56,6 @@ finally { long realElapsed = System.currentTimeMillis() - realStart; - final long userStop; - final long systemStop; - if (userStart > 0) - { - userStop = getCurrentThreadUserTime(); - systemStop = getCurrentThreadSystemTime(); - } - else - { - userStop = -1; - systemStop = -1; - } long count = Cons.getCount(); Stream out = checkCharacterOutputStream(Symbol.TRACE_OUTPUT.symbolValue()); @@ -111,15 +64,6 @@ sb.append(String.valueOf((float)realElapsed / 1000)); sb.append(" seconds real time"); sb.append(System.getProperty("line.separator")); - if (userStart > 0) - { - sb.append(String.valueOf((float)(userStop - userStart) / 100)); - sb.append(" seconds user run time"); - sb.append(System.getProperty("line.separator")); - sb.append(String.valueOf((float)(systemStop - systemStart) / 100)); - sb.append(" seconds system run time"); - sb.append(System.getProperty("line.separator")); - } sb.append(count); sb.append(" cons cell"); if (count != 1) @@ -149,19 +93,6 @@ @Override public LispObject execute() throws ConditionThrowable { - if (Utilities.isPlatformUnix) - { - long userTime = -1; - long systemTime = -1; - try - { - userTime = getCurrentThreadUserTime(); - systemTime = getCurrentThreadSystemTime(); - } - catch (Throwable t) {} - if (userTime >= 0 && systemTime >= 0) - return number((userTime + systemTime) * 10); - } return number(System.currentTimeMillis()); } }; From ehuelsmann at common-lisp.net Sun Aug 23 08:32:29 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 23 Aug 2009 04:32:29 -0400 Subject: [armedbear-cvs] r12110 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 23 04:32:26 2009 New Revision: 12110 Log: Eliminate (a few) "unchecked" warnings. Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/LispObject.java Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Sun Aug 23 04:32:26 2009 @@ -1220,10 +1220,12 @@ } public static final LispObject loadCompiledFunction(byte[] bytes) throws Throwable { - Class c = (new JavaClassLoader()).loadClassFromByteArray(null, bytes, 0, bytes.length); + Class c = (new JavaClassLoader()) + .loadClassFromByteArray(null, bytes, 0, bytes.length); if (c != null) { Constructor constructor = c.getConstructor((Class[])null); - LispObject obj = (LispObject) constructor.newInstance((Object[])null); + LispObject obj = (LispObject)constructor + .newInstance((Object[])null); if (obj instanceof Function) { ((Function)obj).setClassBytes(bytes); } Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Sun Aug 23 04:32:26 2009 @@ -104,7 +104,7 @@ return this; } - public Object javaInstance(Class c) throws ConditionThrowable + public Object javaInstance(Class c) throws ConditionThrowable { if (c.isAssignableFrom(getClass())) return this; From ehuelsmann at common-lisp.net Sun Aug 23 09:26:15 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 23 Aug 2009 05:26:15 -0400 Subject: [armedbear-cvs] r12111 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 23 05:26:13 2009 New Revision: 12111 Log: Eliminate all unchecked warnings, while also removing generic "SuppressWarnings" annotations. Modified: trunk/abcl/src/org/armedbear/lisp/Java.java trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/LispObject.java Modified: trunk/abcl/src/org/armedbear/lisp/Java.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Java.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Java.java Sun Aug 23 05:26:13 2009 @@ -254,12 +254,12 @@ if (args.length < 1) error(new WrongNumberOfArgumentsException(this)); try { - final Class c = javaClass(args[0]); + final Class c = javaClass(args[0]); int argCount = 0; if (args.length == 2 && args[1] instanceof Fixnum) { argCount = Fixnum.getValue(args[1]); } else { - Class[] parameterTypes = new Class[args.length-1]; + Class[] parameterTypes = new Class[args.length-1]; for (int i = 1; i < args.length; i++) { parameterTypes[i-1] = javaClass(args[i]); } @@ -298,14 +298,14 @@ { if (args.length < 2) error(new WrongNumberOfArgumentsException(this)); - final Class c = javaClass(args[0]); + final Class c = javaClass(args[0]); String methodName = args[1].getStringValue(); try { int argCount = 0; if (args.length == 3 && args[2] instanceof Fixnum) { argCount = ((Fixnum)args[2]).value; } else { - Class[] parameterTypes = new Class[args.length-2]; + Class[] parameterTypes = new Class[args.length-2]; for (int i = 2; i < args.length; i++) parameterTypes[i-2] = javaClass(args[i]); return JavaObject.getInstance(c.getMethod(methodName, @@ -636,7 +636,7 @@ method = findMethod(c, methodName, args.length - 2); } else method = (Method) JavaObject.getObject(methodArg); - Class[] argTypes = method.getParameterTypes(); + Class[] argTypes = (Class[])method.getParameterTypes(); Object[] methodArgs = new Object[args.length - 2]; for (int i = 2; i < args.length; i++) { LispObject arg = args[i]; @@ -645,7 +645,8 @@ else methodArgs[i-2] = arg.javaInstance(argTypes[i-2]); } - return JavaObject.getInstance(method.invoke(instance, methodArgs), translate); + return JavaObject.getInstance(method.invoke(instance, methodArgs), + translate); } catch (ConditionThrowable t) { throw t; Modified: trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java (original) +++ trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java Sun Aug 23 05:26:13 2009 @@ -79,12 +79,14 @@ } } - public Class loadClassFromByteArray(String className, byte[] classbytes) + public Class loadClassFromByteArray(String className, + byte[] classbytes) { try { long length = classbytes.length; if (length < Integer.MAX_VALUE) { - Class c = defineClass(className, classbytes, 0, (int) length); + Class c = + defineClass(className, classbytes, 0, (int) length); if (c != null) { resolveClass(c); return c; @@ -100,11 +102,11 @@ return null; } - public Class loadClassFromByteArray(String className, byte[] bytes, - int offset, int length) + public Class loadClassFromByteArray(String className, byte[] bytes, + int offset, int length) { try { - Class c = defineClass(className, bytes, offset, length); + Class c = defineClass(className, bytes, offset, length); if (c != null) { resolveClass(c); return c; Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Sun Aug 23 05:26:13 2009 @@ -1220,7 +1220,7 @@ } public static final LispObject loadCompiledFunction(byte[] bytes) throws Throwable { - Class c = (new JavaClassLoader()) + Class c = (new JavaClassLoader()) .loadClassFromByteArray(null, bytes, 0, bytes.length); if (c != null) { Constructor constructor = c.getConstructor((Class[])null); Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Sun Aug 23 05:26:13 2009 @@ -104,7 +104,7 @@ return this; } - public Object javaInstance(Class c) throws ConditionThrowable + public Object javaInstance(Class c) throws ConditionThrowable { if (c.isAssignableFrom(getClass())) return this; From ehuelsmann at common-lisp.net Sun Aug 23 14:24:08 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 23 Aug 2009 10:24:08 -0400 Subject: [armedbear-cvs] r12112 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 23 10:24:05 2009 New Revision: 12112 Log: Re-instate accidentally commented out DELETE-FILE form. 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 Sun Aug 23 10:24:05 2009 @@ -8477,8 +8477,7 @@ (setf compiled-function (load-compiled-function (compile-defun name expr env tempfile)))) - ;;(delete-file tempfile) - )) + (delete-file tempfile))) (when (and name (functionp compiled-function)) (sys::set-function-definition name compiled-function definition)) (or name compiled-function))) From ehuelsmann at common-lisp.net Sun Aug 23 17:40:00 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 23 Aug 2009 13:40:00 -0400 Subject: [armedbear-cvs] r12113 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 23 13:39:56 2009 New Revision: 12113 Log: Fix types used in THE type-checking for structure access. 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 Sun Aug 23 13:39:56 2009 @@ -345,7 +345,7 @@ (t `((declaim (ftype (function * ,type) ,accessor-name)) (defun ,accessor-name (instance) - (structure-ref (the ',*dd-name* instance) ,index)) + (structure-ref (the ,*dd-name* instance) ,index)) (define-source-transform ,accessor-name (instance) ,(if (eq type 't) ``(structure-ref (the ,',*dd-name* ,instance) ,,index) @@ -370,7 +370,7 @@ `(aset (truly-the ,',*dd-type* ,instance) ,,index ,value)))) (t `((defun (setf ,accessor-name) (value instance) - (structure-set (the ',*dd-name* instance) ,index value)) + (structure-set (the ,*dd-name* instance) ,index value)) (define-source-transform (setf ,accessor-name) (value instance) `(structure-set (the ,',*dd-name* ,instance) ,,index ,value))))))) From ehuelsmann at common-lisp.net Sun Aug 23 19:08:07 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 23 Aug 2009 15:08:07 -0400 Subject: [armedbear-cvs] r12114 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 23 15:08:04 2009 New Revision: 12114 Log: Verify simple types (single symbol types) while interpreting the THE special operator. Note: This helps argument verification while interpreting structure slot accessors. Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Sun Aug 23 15:08:04 2009 @@ -371,7 +371,15 @@ { if (args.length() != 2) return error(new WrongNumberOfArgumentsException(this)); - return eval(args.cadr(), env, LispThread.currentThread()); + LispObject rv = eval(args.cadr(), env, LispThread.currentThread()); + + LispObject type = args.car(); + if (type instanceof Symbol + || type instanceof BuiltInClass) + if (rv.typep(type) == NIL) + type_error(rv, type); + + return rv; } }; From ehuelsmann at common-lisp.net Sun Aug 23 21:50:07 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 23 Aug 2009 17:50:07 -0400 Subject: [armedbear-cvs] r12115 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 23 17:50:04 2009 New Revision: 12115 Log: Convert FLET BLOCK-NODEs to flet-nodes. Note: This commit also fixes the failure of some ANSI tests introduced in r12086 by special casing SETF function handling. This special casing is temporary. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Aug 23 17:50:04 2009 @@ -640,15 +640,15 @@ (push local-function local-functions))) ((with-saved-compiler-policy (process-optimization-declarations (cddr form)) - (let* ((block (make-block-node '(FLET))) + (let* ((block (make-flet-node)) (*blocks* (cons block *blocks*)) (body (cddr form)) (*visible-variables* *visible-variables*)) - (setf (block-free-specials block) + (setf (flet-free-specials block) (process-declarations-for-vars body nil block)) - (dolist (special (block-free-specials block)) + (dolist (special (flet-free-specials block)) (push special *visible-variables*)) - (setf (block-form block) + (setf (flet-form block) (list* (car form) local-functions (p1-body (cddr form)))) block))))) 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 Sun Aug 23 17:50:04 2009 @@ -4954,7 +4954,7 @@ (defknown p2-flet-node (t t t) t) (defun p2-flet-node (block target representation) - (let* ((form (block-form block)) + (let* ((form (flet-form block)) (*local-functions* *local-functions*) (*visible-variables* *visible-variables*) (local-functions (cadr form)) @@ -4963,9 +4963,10 @@ (p2-flet-process-compiland local-function)) (dolist (local-function local-functions) (push local-function *local-functions*)) - (dolist (special (block-free-specials block)) + (dolist (special (flet-free-specials block)) (push special *visible-variables*)) - (compile-progn-body body target representation))) + (let ((*blocks* (cons block *blocks*))) + (compile-progn-body body target representation)))) (defknown p2-labels-node (t t t) t) (defun p2-labels-node (block target representation) @@ -7913,10 +7914,14 @@ (cond ((eq name 'LET) (p2-let/let*-node form target representation)) - ((eq name 'FLET) - (p2-flet-node form target representation)) ((eq name 'LABELS) (p2-labels-node form target representation)) + ((eq name 'SETF) ;; SETF functions create + ;; consp block names, if we're unlucky + (p2-block-node form target representation)) + (t + (print name) + (aver (not "Can't happen."))) ))))) ((node-p form) (cond @@ -7929,6 +7934,8 @@ ((m-v-b-node-p form) (p2-m-v-b-node form target) (fix-boxing representation nil)) + ((flet-node-p form) + (p2-flet-node form target representation)) ((locally-node-p form) (p2-locally-node form target representation)) ((catch-node-p form) From ehuelsmann at common-lisp.net Mon Aug 24 19:21:16 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 24 Aug 2009 15:21:16 -0400 Subject: [armedbear-cvs] r12116 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Aug 24 15:21:13 2009 New Revision: 12116 Log: Convert LABELS BLOCK-NODEs to LABELS-NODEs. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.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 Mon Aug 24 15:21:13 2009 @@ -670,15 +670,15 @@ (let ((*visible-variables* *visible-variables*) (*current-compiland* (local-function-compiland local-function))) (p1-compiland (local-function-compiland local-function)))) - (let* ((block (make-block-node '(LABELS))) + (let* ((block (make-labels-node)) (*blocks* (cons block *blocks*)) (body (cddr form)) (*visible-variables* *visible-variables*)) - (setf (block-free-specials block) + (setf (labels-free-specials block) (process-declarations-for-vars body nil block)) - (dolist (special (block-free-specials block)) + (dolist (special (labels-free-specials block)) (push special *visible-variables*)) - (setf (block-form block) + (setf (labels-form block) (list* (car form) local-functions (p1-body (cddr form)))) block)))) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Mon Aug 24 15:21:13 2009 @@ -4970,7 +4970,7 @@ (defknown p2-labels-node (t t t) t) (defun p2-labels-node (block target representation) - (let* ((form (block-form block)) + (let* ((form (labels-form block)) (*local-functions* *local-functions*) (*visible-variables* *visible-variables*) (local-functions (cadr form)) @@ -4985,9 +4985,10 @@ (setf (variable-register variable) (allocate-register))))) (dolist (local-function local-functions) (p2-labels-process-compiland local-function)) - (dolist (special (block-free-specials block)) + (dolist (special (labels-free-specials block)) (push special *visible-variables*)) - (compile-progn-body body target representation))) + (let ((*blocks* (cons block *blocks*))) + (compile-progn-body body target representation)))) (defun p2-lambda (compiland target) (let* ((lambda-list (cadr (compiland-lambda-expression compiland)))) @@ -7914,11 +7915,11 @@ (cond ((eq name 'LET) (p2-let/let*-node form target representation)) - ((eq name 'LABELS) - (p2-labels-node form target representation)) - ((eq name 'SETF) ;; SETF functions create +;; ((eq name 'LABELS) +;; (p2-labels-node form target representation)) +;; ((eq name 'SETF) ;; SETF functions create ;; consp block names, if we're unlucky - (p2-block-node form target representation)) +;; (p2-block-node form target representation)) (t (print name) (aver (not "Can't happen."))) @@ -7936,6 +7937,8 @@ (fix-boxing representation nil)) ((flet-node-p form) (p2-flet-node form target representation)) + ((labels-node-p form) + (p2-labels-node form target representation)) ((locally-node-p form) (p2-locally-node form target representation)) ((catch-node-p form) From mevenson at common-lisp.net Tue Aug 25 09:28:05 2009 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 25 Aug 2009 05:28:05 -0400 Subject: [armedbear-cvs] r12117 - trunk/abcl Message-ID: Author: mevenson Date: Tue Aug 25 05:28:02 2009 New Revision: 12117 Log: Note change in Java/Lisp stack frames facility. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Tue Aug 25 05:28:02 2009 @@ -29,8 +29,16 @@ now to be considered as deprecated, marked to be removed with 0.22. + * Stacktraces now contain calls through Java code relevant to + debugging (Tobias Rittweiler). + + Backtrace functionality been moved from EXT:BACKTRACE-AS-LIST to + SYS:BACKTRACE to mark this changes. The methods SYS:FRAME-TO-STRING + and SYS:FRAME-TO-LIST can be used to inspect the new + LISP_STACK_FRAME and JAVA_STACK_FRAME objects. Version 0.15.0 +svn://common-lisp.net/project/armedbear/svn/tags/0.15.0/abcl (07 Jun, 2009) Summary of changes: From ehuelsmann at common-lisp.net Wed Aug 26 21:26:54 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 26 Aug 2009 17:26:54 -0400 Subject: [armedbear-cvs] r12118 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Aug 26 17:26:51 2009 New Revision: 12118 Log: Adjust BLOCK-NODE dispatch routine. Note: The SETF part can only be removed once all non-BLOCK-NODEs have been migrated to their respective node type structures. 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 Wed Aug 26 17:26:51 2009 @@ -7915,11 +7915,9 @@ (cond ((eq name 'LET) (p2-let/let*-node form target representation)) -;; ((eq name 'LABELS) -;; (p2-labels-node form target representation)) -;; ((eq name 'SETF) ;; SETF functions create + ((eq name 'SETF) ;; SETF functions create ;; consp block names, if we're unlucky -;; (p2-block-node form target representation)) + (p2-block-node form target representation)) (t (print name) (aver (not "Can't happen."))) From mevenson at common-lisp.net Thu Aug 27 09:33:23 2009 From: mevenson at common-lisp.net (Mark Evenson) Date: Thu, 27 Aug 2009 05:33:23 -0400 Subject: [armedbear-cvs] r12119 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu Aug 27 05:33:21 2009 New Revision: 12119 Log: Fix ticket#61 for THE evaluated with DEFTYPEd forms. Shouldn't the call to the Lisp-side TYPEP be added at the "top-level" typep() defined on LispObject? Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Thu Aug 27 05:33:21 2009 @@ -376,9 +376,17 @@ LispObject type = args.car(); if (type instanceof Symbol || type instanceof BuiltInClass) - if (rv.typep(type) == NIL) - type_error(rv, type); - + if (rv.typep(type) == NIL) { + // Try to call the Lisp-side TYPEP, as we will miss + // DEFTYPEd types. + Symbol typep + = PACKAGE_SYS.findAccessibleSymbol("TYPEP"); + LispObject result + = typep.getSymbolFunction().execute(rv, type); + if (result == NIL) { + type_error(rv, type); + } + } return rv; } }; 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 Thu Aug 27 05:33:21 2009 @@ -7915,9 +7915,11 @@ (cond ((eq name 'LET) (p2-let/let*-node form target representation)) - ((eq name 'SETF) ;; SETF functions create +;; ((eq name 'LABELS) +;; (p2-labels-node form target representation)) +;; ((eq name 'SETF) ;; SETF functions create ;; consp block names, if we're unlucky - (p2-block-node form target representation)) +;; (p2-block-node form target representation)) (t (print name) (aver (not "Can't happen."))) From mevenson at common-lisp.net Thu Aug 27 09:52:43 2009 From: mevenson at common-lisp.net (Mark Evenson) Date: Thu, 27 Aug 2009 05:52:43 -0400 Subject: [armedbear-cvs] r12120 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu Aug 27 05:52:41 2009 New Revision: 12120 Log: Merged branches. 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 Thu Aug 27 05:52:41 2009 @@ -7915,11 +7915,9 @@ (cond ((eq name 'LET) (p2-let/let*-node form target representation)) -;; ((eq name 'LABELS) -;; (p2-labels-node form target representation)) -;; ((eq name 'SETF) ;; SETF functions create + ((eq name 'SETF) ;; SETF functions create ;; consp block names, if we're unlucky -;; (p2-block-node form target representation)) + (p2-block-node form target representation)) (t (print name) (aver (not "Can't happen."))) From mevenson at common-lisp.net Fri Aug 28 07:36:35 2009 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 28 Aug 2009 03:36:35 -0400 Subject: [armedbear-cvs] r12121 - trunk/abcl Message-ID: Author: mevenson Date: Fri Aug 28 03:36:32 2009 New Revision: 12121 Log: Don't include the ScriptEngineFactory in the META-INF abcl.jar packaging if not compiling JSR-223. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Fri Aug 28 03:36:32 2009 @@ -278,7 +278,9 @@ value="${version.src}"/> - + + From ehuelsmann at common-lisp.net Fri Aug 28 07:52:49 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 28 Aug 2009 03:52:49 -0400 Subject: [armedbear-cvs] r12122 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 28 03:52:48 2009 New Revision: 12122 Log: Allow file-compilation of already-defined structure classes in order to support the bootstrapping process. Modified: trunk/abcl/src/org/armedbear/lisp/StructureClass.java Modified: trunk/abcl/src/org/armedbear/lisp/StructureClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StructureClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StructureClass.java Fri Aug 28 03:52:48 2009 @@ -95,7 +95,23 @@ LispObject directSlots = checkList(second); LispObject slots = checkList(third); Symbol include = checkSymbol(fourth); - StructureClass c = new StructureClass(symbol); + LispClass existingClass = LispClass.findClass(symbol); + StructureClass c; + + if (existingClass instanceof StructureClass) + // Change the existing class definition if there is one. + // The compiler has this scenario, where it is first loaded + // and subsequently run through the file compiler - which + // re-creates the same structure and breaks the inheritance + // if we don't re-use the existing class. Reusing the + // existing class is alright in this case, since we're + // recreating the same class. + // Redefinition of structures is undefined in the CLHS. + // As per the DEFSTRUCT-REDEFINITION it is allowed, but + // consequences are undefined. + c = (StructureClass)existingClass; + else + c = new StructureClass(symbol); if (include != NIL) { LispClass includedClass = LispClass.findClass(include); if (includedClass == null) From ehuelsmann at common-lisp.net Fri Aug 28 09:04:49 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 28 Aug 2009 05:04:49 -0400 Subject: [armedbear-cvs] r12123 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 28 05:04:44 2009 New Revision: 12123 Log: Convert LET BLOCK-NODEs to LET/LET*-NODEs and clean up the BLOCK-NODE structure to serve BLOCKs only. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri Aug 28 05:04:44 2009 @@ -200,8 +200,7 @@ (defun p1-let/let* (form) (declare (type cons form)) (let* ((*visible-variables* *visible-variables*) - (block (make-block-node '(LET))) - (*blocks* (cons block *blocks*)) + (block (make-let/let*-node)) (op (%car form)) (varlist (cadr form)) (body (cddr form))) @@ -222,18 +221,19 @@ (dolist (variable vars) (when (special-variable-p (variable-name variable)) (setf (variable-special-p variable) t - (block-environment-register block) t))) + (let-environment-register block) t))) ;; For processing declarations, we want to walk the variable list from ;; last to first, since declarations apply to the last-defined variable ;; with the specified name. - (setf (block-free-specials block) + (setf (let-free-specials block) (process-declarations-for-vars body (reverse vars) block)) - (setf (block-vars block) vars) + (setf (let-vars block) vars) ;; Make free specials visible. - (dolist (variable (block-free-specials block)) + (dolist (variable (let-free-specials block)) (push variable *visible-variables*))) - (setf body (p1-body body)) - (setf (block-form block) (list* op varlist body)) + (let ((*blocks* (cons block *blocks*))) + (setf body (p1-body body))) + (setf (let-form block) (list* op varlist body)) block)) (defun p1-locally (form) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 28 05:04:44 2009 @@ -4072,7 +4072,7 @@ (defun propagate-vars (block) (let ((removed '())) - (dolist (variable (block-vars block)) + (dolist (variable (let-vars block)) (unless (or (variable-special-p variable) (variable-closure-index variable)) (when (eql (variable-writes variable) 0) @@ -4104,7 +4104,7 @@ 'sys::dotimes-limit-variable-p) (let* ((symbol (get (variable-name variable) 'sys::dotimes-index-variable-name)) - (index-variable (find-variable symbol (block-vars block)))) + (index-variable (find-variable symbol (let-vars block)))) (when index-variable (setf (get (variable-name index-variable) 'sys::dotimes-limit-variable-name) @@ -4119,7 +4119,7 @@ (push variable removed))))))) (when removed (dolist (variable removed) - (setf (block-vars block) (remove variable (block-vars block))))))) + (setf (let-vars block) (remove variable (let-vars block))))))) (defun derive-variable-representation (variable block &key (type nil type-supplied-p)) @@ -4156,7 +4156,7 @@ 'sys::dotimes-limit-variable-name)) (limit-variable (and name (or (find-variable name - (block-vars block)) + (let-vars block)) (find-visible-variable name))))) (when limit-variable (derive-variable-representation limit-variable block) @@ -4264,7 +4264,7 @@ (defknown p2-let-bindings (t) t) (defun p2-let-bindings (block) - (dolist (variable (block-vars block)) + (dolist (variable (let-vars block)) (unless (or (variable-special-p variable) (variable-closure-index variable) (zerop (variable-reads variable))) @@ -4279,7 +4279,7 @@ ;; been evaluated. Note that we can't just push the values on the stack ;; because we'll lose JVM stack consistency if there is a non-local ;; transfer of control from one of the initforms. - (dolist (variable (block-vars block)) + (dolist (variable (let-vars block)) (let* ((initform (variable-initform variable)) (unused-p (and (not (variable-special-p variable)) ;; If it's never read, we don't care about writes. @@ -4320,7 +4320,7 @@ (aload (car temp)) (compile-binding (cdr temp)))) ;; Now make the variables visible. - (dolist (variable (block-vars block)) + (dolist (variable (let-vars block)) (push variable *visible-variables*)) t) @@ -4329,7 +4329,7 @@ (let ((must-clear-values nil)) (declare (type boolean must-clear-values)) ;; Generate code to evaluate initforms and bind variables. - (dolist (variable (block-vars block)) + (dolist (variable (let-vars block)) (let* ((initform (variable-initform variable)) (unused-p (and (not (variable-special-p variable)) (zerop (variable-reads variable)) @@ -4401,14 +4401,14 @@ t) (defun p2-let/let*-node (block target representation) - (let* ((*blocks* (cons block *blocks*)) + (let* ( (*register* *register*) - (form (block-form block)) + (form (let-form block)) (*visible-variables* *visible-variables*) (specialp nil) (label-START (gensym))) ;; Walk the variable list looking for special bindings and unused lexicals. - (dolist (variable (block-vars block)) + (dolist (variable (let-vars block)) (cond ((variable-special-p variable) (setf specialp t)) ((zerop (variable-reads variable)) @@ -4416,8 +4416,8 @@ ;; If there are any special bindings... (when specialp ;; We need to save current dynamic environment. - (setf (block-environment-register block) (allocate-register)) - (save-dynamic-environment (block-environment-register block)) + (setf (let-environment-register block) (allocate-register)) + (save-dynamic-environment (let-environment-register block)) (label label-START)) (propagate-vars block) (ecase (car form) @@ -4426,14 +4426,15 @@ (LET* (p2-let*-bindings block))) ;; Make declarations of free specials visible. - (dolist (variable (block-free-specials block)) + (dolist (variable (let-free-specials block)) (push variable *visible-variables*)) ;; Body of LET/LET*. (with-saved-compiler-policy (process-optimization-declarations (cddr form)) - (compile-progn-body (cddr form) target representation)) + (let ((*blocks* (cons block *blocks*))) + (compile-progn-body (cddr form) target representation))) (when specialp - (restore-environment-and-make-handler (block-environment-register block) + (restore-environment-and-make-handler (let-environment-register block) label-START)))) (defknown p2-locally-node (t t t) t) @@ -7907,23 +7908,12 @@ (aver nil)))) ((var-ref-p form) (compile-var-ref form target representation)) - ((block-node-p form) - (let ((name (block-name form))) - (if (not (consp name)) - (p2-block-node form target representation) - (let ((name (car name))) - (cond - ((eq name 'LET) - (p2-let/let*-node form target representation)) - ((eq name 'SETF) ;; SETF functions create - ;; consp block names, if we're unlucky - (p2-block-node form target representation)) - (t - (print name) - (aver (not "Can't happen."))) - ))))) ((node-p form) (cond + ((block-node-p form) + (p2-block-node form target representation)) + ((let/let*-node-p form) + (p2-let/let*-node form target representation)) ((tagbody-node-p form) (p2-tagbody-node form target) (fix-boxing representation nil)) Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Fri Aug 28 05:04:44 2009 @@ -438,13 +438,7 @@ ;; True if there is any RETURN from this block. return-p ;; True if there is a non-local RETURN from this block. - non-local-return-p - ;; If non-nil, register containing saved dynamic environment for this block. - environment-register - ;; Only used in LET/LET*/M-V-B nodes. - vars - free-specials - ) + non-local-return-p) (defvar *blocks* ()) @@ -481,9 +475,7 @@ " (or (unwind-protect-node-p object) (catch-node-p object) - (synchronized-node-p object) - (and (block-node-p object) - (equal (block-name object) '(THREADS:SYNCHRONIZED-ON))))) + (synchronized-node-p object))) (defknown enclosed-by-protected-block-p (&optional t) boolean) @@ -503,10 +495,8 @@ (dolist (enclosing-block *blocks*) (when (eq enclosing-block outermost-block) (return nil)) - (when (or (and (binding-node-p enclosing-block) - (binding-node-environment-register enclosing-block)) - (and (block-node-p enclosing-block) - (block-environment-register enclosing-block))) + (when (and (binding-node-p enclosing-block) + (binding-node-environment-register enclosing-block)) (return t)))) (defknown environment-register-to-restore (&optional t) t) @@ -520,8 +510,6 @@ (return-from environment-register-to-restore last-register)) (or (and (binding-node-p block) (binding-node-environment-register block)) - (and (block-node-p block) - (block-environment-register block)) last-register))) (reduce #'outermost-register *blocks* :initial-value nil))) From ehuelsmann at common-lisp.net Fri Aug 28 10:55:05 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 28 Aug 2009 06:55:05 -0400 Subject: [armedbear-cvs] r12124 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 28 06:55:00 2009 New Revision: 12124 Log: Proposed solution to ticket #61: skip type checking on DEFTYPE-d types (usually complex types). Note: with this change structure slot accessors still verify their argument types. Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java trunk/abcl/src/org/armedbear/lisp/Symbol.java Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Fri Aug 28 06:55:00 2009 @@ -373,20 +373,25 @@ return error(new WrongNumberOfArgumentsException(this)); LispObject rv = eval(args.cadr(), env, LispThread.currentThread()); + // check only the most simple types: single symbols + // (class type specifiers/primitive types) + // DEFTYPE-d types need expansion; + // doing so would slow down our execution too much + + // An implementation is allowed not to check the type, + // the fact that we do so here is mainly driven by the + // requirement to verify argument types in structure-slot + // accessors (defstruct.lisp) + + // The policy below is in line with the level of verification + // in the compiler at *safety* levels below 3 LispObject type = args.car(); - if (type instanceof Symbol + if ((type instanceof Symbol + && get(type, Symbol.DEFTYPE_DEFINITION) == NIL) || type instanceof BuiltInClass) - if (rv.typep(type) == NIL) { - // Try to call the Lisp-side TYPEP, as we will miss - // DEFTYPEd types. - Symbol typep - = PACKAGE_SYS.findAccessibleSymbol("TYPEP"); - LispObject result - = typep.getSymbolFunction().execute(rv, type); - if (result == NIL) { + if (rv.typep(type) == NIL) type_error(rv, type); - } - } + return rv; } }; Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Aug 28 06:55:00 2009 @@ -3011,6 +3011,8 @@ PACKAGE_SYS.addInternalSymbol("COMMA-MACRO"); public static final Symbol DATUM = PACKAGE_SYS.addInternalSymbol("DATUM"); + public static final Symbol DEFTYPE_DEFINITION = + PACKAGE_SYS.addInternalSymbol("DEFTYPE-DEFINITION"); public static final Symbol EXPECTED_TYPE = PACKAGE_SYS.addInternalSymbol("EXPECTED-TYPE"); public static final Symbol FORMAT_ARGUMENTS = From ehuelsmann at common-lisp.net Sun Aug 30 20:21:38 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 30 Aug 2009 16:21:38 -0400 Subject: [armedbear-cvs] r12125 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 30 16:21:35 2009 New Revision: 12125 Log: Followup to r12122: Don't redefine the same class, instead disallow redefinition, returning the pre-existing class. Modified: trunk/abcl/src/org/armedbear/lisp/StructureClass.java Modified: trunk/abcl/src/org/armedbear/lisp/StructureClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StructureClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StructureClass.java Sun Aug 30 16:21:35 2009 @@ -92,26 +92,23 @@ throws ConditionThrowable { Symbol symbol = checkSymbol(first); + LispClass existingClass = LispClass.findClass(symbol); + + if (existingClass instanceof StructureClass) + // DEFSTRUCT-REDEFINITION write-up + // states the effects from re-definition are undefined + // we punt: our compiler bootstrapping depends on + // the class not being redefined (remaining in the + // same location in the class hierarchy) + return existingClass; + + + LispObject directSlots = checkList(second); LispObject slots = checkList(third); Symbol include = checkSymbol(fourth); - LispClass existingClass = LispClass.findClass(symbol); - StructureClass c; - if (existingClass instanceof StructureClass) - // Change the existing class definition if there is one. - // The compiler has this scenario, where it is first loaded - // and subsequently run through the file compiler - which - // re-creates the same structure and breaks the inheritance - // if we don't re-use the existing class. Reusing the - // existing class is alright in this case, since we're - // recreating the same class. - // Redefinition of structures is undefined in the CLHS. - // As per the DEFSTRUCT-REDEFINITION it is allowed, but - // consequences are undefined. - c = (StructureClass)existingClass; - else - c = new StructureClass(symbol); + StructureClass c = new StructureClass(symbol); if (include != NIL) { LispClass includedClass = LispClass.findClass(include); if (includedClass == null) From ehuelsmann at common-lisp.net Sun Aug 30 21:44:44 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 30 Aug 2009 17:44:44 -0400 Subject: [armedbear-cvs] r12126 - trunk/abcl Message-ID: Author: ehuelsmann Date: Sun Aug 30 17:44:40 2009 New Revision: 12126 Log: Update CHANGES. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Sun Aug 30 17:44:40 2009 @@ -2,44 +2,59 @@ (unreleased) Summary of changes: - * Better initarg checking for make-instance and change-class. Fixes ansi-test - errors CHANGE-CLASS.1.11, MAKE-INSTANCE.ERROR.3, MAKE-INSTANCE.ERROR.4, - CHANGE-CLASS.ERROR.4 and SHARED-INITIALIZE.ERROR.4. + * Fixed generated wrapper for path names with spaces (Windows) + * Fixed ticket #58: Inspection of Java objects in Lisp code + * Restored functionality of the built-in profiler + * Profiler extended with hot-spot counting (as opposed to call counting) + * Stack sampling in the profiler moved to scheduler thread to + reduce impact on the program execution thread + * THE type-checking for the interpreter + (for simple-enough type specifications) + * Added structure argument type checking in structure slot + accessor functions + * Make GENSYM thread-safe + * Various performance fixes found by running the raytracer + from http://www.ffconsultancy.com/languages/ray_tracer/benchmark.html + * Better initarg checking for make-instance and change-class + Fixes ansi-test errors CHANGE-CLASS.1.11, MAKE-INSTANCE.ERROR.3, + MAKE-INSTANCE.ERROR.4, CHANGE-CLASS.ERROR.4 and SHARED-INITIALIZE.ERROR.4 * Improve performance of StackFrames (Erik Huelsmann, Ville Voutilainen, with input from Peter Graves and Douglas Miles) - * Improve performance of CLOS eql-specializers via cache (Anton Vodonosov). - * 'build-from-lisp.sh' shell script (Tobias Rittweiler). + * Improve performance of CLOS eql-specializers via cache (Anton Vodonosov) + * 'build-from-lisp.sh' shell script (Tobias Rittweiler) * New threading primitives aligned with Java/JVM constructs (Erik Huelsmann) SYNCHRONIZED-ON OBJECT-NOTIFY OBJECT-NOTIFY-ALL - - * THREADS package created to hold threads related primitives: + * THREADS package created to hold threads related primitives: THREADP THREAD-UNLOCK THREAD-LOCK THREAD-NAME THREAD-ALIVE-P CURRENT-THREAD DESTROY-THREAD INTERRUPT-THREAD WITH-THREAD-LOCK MAKE-THREAD-LOCK MAKE-THREAD INTERRUPT-THREAD MAPCAR-THREADS - + GET-MUTEX MAKE-MUTEX WITH-MUTEX RELEASE-MUTEX These primitives are still part of the EXTENSIONS package but are now to be considered as deprecated, marked to be removed with - 0.22. + 0.22 + * Stacktraces now contain calls through Java code relevant to + debugging (Tobias Rittweiler) + + Backtrace functionality been moved from EXT:BACKTRACE-AS-LIST to + SYS:BACKTRACE to mark this changes. The methods SYS:FRAME-TO-STRING + and SYS:FRAME-TO-LIST can be used to inspect the new + LISP_STACK_FRAME and JAVA_STACK_FRAME objects + * Various stream input performance optimizations + * Fixed breakage when combining Gray streams and the pretty printer + * Performance improvements for resolution of non-recursive #=n and #n# - * Stacktraces now contain calls through Java code relevant to - debugging (Tobias Rittweiler). - Backtrace functionality been moved from EXT:BACKTRACE-AS-LIST to - SYS:BACKTRACE to mark this changes. The methods SYS:FRAME-TO-STRING - and SYS:FRAME-TO-LIST can be used to inspect the new - LISP_STACK_FRAME and JAVA_STACK_FRAME objects. - Version 0.15.0 svn://common-lisp.net/project/armedbear/svn/tags/0.15.0/abcl -(07 Jun, 2009) +(07 Jun, 2009) Summary of changes: * 2 more MOP exported symbols to support Cells port