March 2006 - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 31 Mar '06

31 Mar '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14758 Modified Files: integers.lisp Log Message: Fixed nasty bug in + as showed up e.g. in (1- most-negative-fixnum). Fixed bugs in ash left-shift, particularly of negatives. Added trivial floatp. --- /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2005/09/18 15:58:09 1.119 +++ /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2006/03/31 20:57:48 1.120 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.119 2005/09/18 15:58:09 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.120 2006/03/31 20:57:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -382,7 +382,7 @@ (:negl :ecx) (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) (:call-local-pf box-u32-ecx) - (:movl ,(dpb 1 (byte 16 16) + (:movl ,(dpb 4 (byte 16 16) (movitz:tag :bignum #xff)) (:eax ,movitz:+other-type-offset+)) (:jmp 'fix-fix-ok) @@ -762,32 +762,54 @@ ((= 0 count) integer) ((= 0 integer) 0) - ((plusp count) - (let ((result-length (+ (integer-length integer) count))) + ((typep count '(integer 0 *)) + (let ((result-length (+ (integer-length (if (minusp integer) (1- integer) integer)) + count))) (cond ((<= result-length 29) (with-inline-assembly (:returns :eax) (:compile-two-forms (:eax :ecx) integer count) (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) (:shll :cl :eax))) - (t (check-type integer (integer 0 *)) - (let ((result (%make-bignum (ceiling result-length 32)))) - (dotimes (i (* 2 (%bignum-bigits result))) - (setf (memref result -2 :index i :type :unsigned-byte16) - (let ((pos (- (* i 16) count))) - (cond - ((minusp (+ pos 16)) 0) - ((<= 0 pos) - (ldb (byte 16 pos) integer)) - (t (ash (ldb (byte (+ pos 16) 0) integer) - (- pos))))))) - (assert (or (plusp (memref result -2 - :index (+ -1 (* 2 (%bignum-bigits result))) - :type :unsigned-byte16)) - (plusp (memref result -2 - :index (+ -2 (* 2 (%bignum-bigits result))) - :type :unsigned-byte16)))) - (bignum-canonicalize result)))))) + ((typep integer 'positive-fixnum) + (let ((result (%make-bignum (ceiling result-length 32) 0))) + (setf (memref result (movitz-type-slot-offset 'movitz-bignum 'bigit0) + :type :unsigned-byte32) + integer) + (bignum-shift-leftf result count))) + ((typep integer 'positive-bignum) + (let ((result (%make-bignum (ceiling result-length 32)))) + (dotimes (i (* 2 (%bignum-bigits result))) + (setf (memref result -2 :index i :type :unsigned-byte16) + (let ((pos (- (* i 16) count))) + (cond + ((minusp (+ pos 16)) 0) + ((<= 0 pos) + (ldb (byte 16 pos) integer)) + (t (ash (ldb (byte (+ pos 16) 0) integer) + (- pos))))))) + (assert (or (plusp (memref result -2 + :index (+ -1 (* 2 (%bignum-bigits result))) + :type :unsigned-byte16)) + (plusp (memref result -2 + :index (+ -2 (* 2 (%bignum-bigits result))) + :type :unsigned-byte16)))) + (bignum-canonicalize result))) + ((typep integer 'negative-fixnum) + (let ((result (%make-bignum (ceiling result-length 32) 0))) + (setf (memref result (movitz-type-slot-offset 'movitz-bignum 'bigit0) + :type :unsigned-byte32) + (- integer)) + (%bignum-negate (bignum-shift-leftf result count)))) + ((typep integer 'negative-bignum) + (let ((result (%make-bignum (ceiling result-length 32) 0))) + (dotimes (i (%bignum-bigits integer)) + (setf (memref result (movitz-type-slot-offset 'movitz-bignum 'bigit0) + :index i :type :unsigned-byte32) + (memref integer (movitz-type-slot-offset 'movitz-bignum 'bigit0) + :index i :type :unsigned-byte32))) + (%bignum-negate (bignum-shift-leftf result count)))) + (t (error 'program-error))))) (t (let ((count (- count))) (etypecase integer (fixnum @@ -2225,4 +2247,6 @@ (expt (rootn base-number (denominator power-number)) (numerator power-number))))) - +(defun floatp (x) + (declare (ignore x)) + nil)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 25 Mar '06

25 Mar '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24173 Modified Files: sequences.lisp Log Message: More substitute madness. Might be decent now. Bring on the ANSI tests! --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2006/03/24 22:22:50 1.30 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2006/03/25 20:59:16 1.31 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.30 2006/03/24 22:22:50 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.31 2006/03/25 20:59:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1769,12 +1769,10 @@ (with-funcallable (key) (sequence-dispatch sequence (vector - (apply #'nsubstitute-if newitem predicate (copy-seq sequence) args)) + (apply 'nsubstitute-if newitem predicate (copy-seq sequence) args)) (list (if from-end - (nreverse (nsubstitute-if newitem predicate (reverse sequence) - :start start :end end - :count count :key key)) + (apply 'nsubstitute-if newitem predicate (copy-list sequence) args) (if (or (null sequence) (and end (<= end start))) nil @@ -1862,11 +1860,17 @@ (return sequence))))) ((error 'program-error)))))) (list - (if from-end - (nreverse (nsubstitute newitem predicate (nreverse sequence) - :start start :end end - :count count :key key)) - (let ((p (nthcdr start sequence))) + (let ((p (nthcdr start sequence))) + (if (and from-end count) + (let* ((end (and end (- end start))) + (existing-count (count-if predicate p :key key :end end))) + (do ((i count)) + ((>= i existing-count) + (nsubstitute-if newitem predicate p :end end :key key) + sequence) + (when (predicate (key (car p))) + (incf i)) + (setf p (cdr p)))) (cond ((and (not end) (not count)) (do ((p p (cdr p))) @@ -1896,4 +1900,8 @@ (setf (car p) newitem) (when (>= (incf c) count) (return sequence))))) - ((error 'program-error)))))))))) \ No newline at end of file + ((error 'program-error)))))))))) + +(defun nsubstitute-if-not (newitem predicate sequence &rest keyargs) + (declare (dynamic-extent keyargs)) + (apply #'nsubstitute-if newitem (complement predicate) sequence keyargs))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 24 Mar '06

24 Mar '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv23085 Modified Files: sequences.lisp Log Message: Improved substitute-if. --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2006/03/21 21:23:27 1.29 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2006/03/24 22:22:50 1.30 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.29 2006/03/21 21:23:27 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.30 2006/03/24 22:22:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1775,45 +1775,55 @@ (nreverse (nsubstitute-if newitem predicate (reverse sequence) :start start :end end :count count :key key)) - (let ((sequence (nthcdr start sequence))) - (if (or (null sequence) - (and end (<= end start))) - nil - (let ((new-list (list #0=(let ((x (pop sequence))) - (if (predicate (key x)) - newitem - x))))) - (cond - ((and (not end) (not count)) - (do ((new-tail new-list (cdr new-tail))) - ((endp sequence) new-list) - (setf (cdr new-tail) (list #0#)))) - ((and end (not count)) - (do ((i (- end start) (1- i)) - (new-tail new-list (cdr new-tail))) - ((or (endp sequence) (<= i 0)) new-list) - (setf (cdr new-tail) (list #0#)))) - ((and (not end) count) - (do ((c 0) - (new-tail new-list (cdr new-tail))) - ((or (endp sequence) (>= c count)) - (setf (cdr new-tail) - (copy-list sequence)) - new-list) + (if (or (null sequence) + (and end (<= end start))) + nil + (multiple-value-bind (new-list new-tail) + (if (= 0 start) + (let ((new-list (list #0=(let ((x (pop sequence))) + (if (predicate (key x)) + newitem + x))))) + (values new-list new-list)) + (do* ((new-list (list (pop sequence))) + (new-tail new-list (cdr new-tail)) + (i 1 (1+ i))) + ((or (endp sequence) (>= i start)) + (values new-list new-tail)) + (setf (cdr new-tail) (list (pop sequence))))) + (cond + ((and (not end) (not count)) + (do () + ((endp sequence) new-list) + (setf new-tail + (setf (cdr new-tail) (list #0#))))) + ((and end (not count)) + (do ((i (- end start 1) (1- i))) + ((or (endp sequence) (<= i 0)) + (setf (cdr new-tail) (copy-list sequence)) + new-list) + (setf new-tail + (setf (cdr new-tail) (list #0#))))) + ((and (not end) count) + (do ((c 0)) + ((or (endp sequence) (>= c count)) + (setf (cdr new-tail) (copy-list sequence)) + new-list) + (setf new-tail (setf (cdr new-tail) #1=(list (let ((x (pop sequence))) (if (predicate (key x)) (progn (incf c) newitem) - x)))))) - ((and end count) - (do ((i (- end start) (1- i)) - (c 0) - (new-tail new-list (cdr new-tail))) - ((or (endp sequence) (<= i 0) (>= c count)) - (setf (cdr new-tail) - (copy-list sequence)) - new-list) - (setf (cdr new-tail) #1#))) - ((error 'program-error)))))))))))) + x))))))) + ((and end count) + (do ((i (- end start 1) (1- i)) + (c 0)) + ((or (endp sequence) (<= i 0) (>= c count)) + (setf (cdr new-tail) + (copy-list sequence)) + new-list) + (setf new-tail + (setf (cdr new-tail) #1#)))) + ((error 'program-error))))))))))) (defun nsubstitute-if (newitem predicate sequence &key (start 0) end count (key 'identity) from-end) "=> sequence"

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 21 Mar '06

21 Mar '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv12316 Modified Files: sequences.lisp Log Message: Added substitute-if and nsubstitute-if, and rewrote substitute and nsubstitute in terms of those. --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2006/03/21 20:23:42 1.28 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2006/03/21 21:23:27 1.29 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.28 2006/03/21 20:23:42 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.29 2006/03/21 21:23:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1735,30 +1735,52 @@ (incf i (length s))) r)) (t (error "Can't concatenate ~S yet: ~:S" result-type sequences)))) - + + (defun substitute (newitem olditem sequence &rest args &key (test 'eql) test-not (start 0) end count (key 'identity) from-end) + "=> result-sequence" (declare (dynamic-extent args)) + (when test-not + (setf test (complement test-not))) + (with-funcallable (test (if test-not (complement test-not) test)) + (substitute-if newitem (lambda (x) (test olditem x)) sequence + :start start :end end + :count count :key key + :from-end from-end))) + +(defun nsubstitute (newitem olditem sequence &rest args + &key (test 'eql) test-not (start 0) end count (key 'identity) from-end) "=> result-sequence" + (declare (dynamic-extent args)) (when test-not (setf test (complement test-not))) - (with-funcallable (test) + (with-funcallable (test (if test-not (complement test-not) test)) + (nsubstitute-if newitem (lambda (x) (test olditem x)) sequence + :start start :end end + :count count :key key + :from-end from-end))) + +(defun substitute-if (newitem predicate sequence &rest args + &key (start 0) end count (key 'identity) from-end) + "=> result-sequence" + (declare (dynamic-extent args)) + (with-funcallable (predicate) (with-funcallable (key) (sequence-dispatch sequence (vector - (apply #'nsubstitute newitem olditem (copy-seq sequence) args)) + (apply #'nsubstitute-if newitem predicate (copy-seq sequence) args)) (list (if from-end - (nreverse (nsubstitute newitem olditem (reverse sequence) - :test test :test-not test-not - :start start :end end - :count count :key key)) + (nreverse (nsubstitute-if newitem predicate (reverse sequence) + :start start :end end + :count count :key key)) (let ((sequence (nthcdr start sequence))) (if (or (null sequence) (and end (<= end start))) nil (let ((new-list (list #0=(let ((x (pop sequence))) - (if (test olditem (key x)) + (if (predicate (key x)) newitem x))))) (cond @@ -1779,7 +1801,7 @@ (copy-list sequence)) new-list) (setf (cdr new-tail) #1=(list (let ((x (pop sequence))) - (if (test olditem (key x)) + (if (predicate (key x)) (progn (incf c) newitem) x)))))) ((and end count) @@ -1793,11 +1815,9 @@ (setf (cdr new-tail) #1#))) ((error 'program-error)))))))))))) -(defun nsubstitute (newitem olditem sequence &key (test 'eql) test-not (start 0) end count (key 'identity) from-end) +(defun nsubstitute-if (newitem predicate sequence &key (start 0) end count (key 'identity) from-end) "=> sequence" - (when test-not - (setf test (complement test-not))) - (with-funcallable (test) + (with-funcallable (predicate) (with-funcallable (key) (sequence-dispatch sequence (vector @@ -1807,34 +1827,33 @@ ((and (not count) (not from-end)) (do ((i start (1+ i))) ((>= i end) sequence) - (when (test olditem (key (ref i))) + (when (predicate (key (ref i))) (setf (ref i) newitem)))) ((and count (not from-end)) (do ((c 0) (i start (1+ i))) ((>= i end) sequence) - (when (test olditem (key (ref i))) + (when (predicate (key (ref i))) (setf (ref i) newitem) (when (>= (incf c) count) (return sequence))))) ((and (not count) from-end) (do ((i (1- end) (1- i))) ((< i start) sequence) - (when (test olditem (key (ref i))) + (when (predicate (key (ref i))) (setf (ref i) newitem)))) ((and count from-end) (do ((c 0) (i (1- end) (1- i))) ((< i start) sequence) - (when (test olditem (key (ref i))) + (when (predicate (key (ref i))) (setf (ref i) newitem) (when (>= (incf c) count) (return sequence))))) ((error 'program-error)))))) (list (if from-end - (nreverse (nsubstitute newitem olditem (nreverse sequence) - :test test :test-not test-not + (nreverse (nsubstitute newitem predicate (nreverse sequence) :start start :end end :count count :key key)) (let ((p (nthcdr start sequence))) @@ -1842,19 +1861,19 @@ ((and (not end) (not count)) (do ((p p (cdr p))) ((endp p) sequence) - (when (test olditem (key (car p))) + (when (predicate (key (car p))) (setf (car p) newitem)))) ((and end (not count)) (do ((i start (1+ i)) (p p (cdr p))) ((or (endp p) (>= i end)) sequence) - (when (test olditem (key (car p))) + (when (predicate (key (car p))) (setf (car p) newitem)))) ((and (not end) count) (do ((c 0) (p p (cdr p))) ((endp p) sequence) - (when (test olditem (key (car p))) + (when (predicate (key (car p))) (setf (car p) newitem) (when (>= (incf c) count) (return sequence))))) @@ -1863,8 +1882,8 @@ (i start (1+ i)) (p p (cdr p))) ((or (endp p) (>= i end)) sequence) - (when (test olditem (key (car p))) + (when (predicate (key (car p))) (setf (car p) newitem) (when (>= (incf c) count) (return sequence))))) - ((error 'program-error)))))))))) + ((error 'program-error)))))))))) \ No newline at end of file

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 21 Mar '06

21 Mar '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3459 Modified Files: sequences.lisp Log Message: Wrote substitute and nsubstitute. --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2005/08/24 07:28:59 1.27 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2006/03/21 20:23:42 1.28 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.27 2005/08/24 07:28:59 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.28 2006/03/21 20:23:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1736,4 +1736,135 @@ r)) (t (error "Can't concatenate ~S yet: ~:S" result-type sequences)))) - +(defun substitute (newitem olditem sequence &rest args + &key (test 'eql) test-not (start 0) end count (key 'identity) from-end) + (declare (dynamic-extent args)) + "=> result-sequence" + (when test-not + (setf test (complement test-not))) + (with-funcallable (test) + (with-funcallable (key) + (sequence-dispatch sequence + (vector + (apply #'nsubstitute newitem olditem (copy-seq sequence) args)) + (list + (if from-end + (nreverse (nsubstitute newitem olditem (reverse sequence) + :test test :test-not test-not + :start start :end end + :count count :key key)) + (let ((sequence (nthcdr start sequence))) + (if (or (null sequence) + (and end (<= end start))) + nil + (let ((new-list (list #0=(let ((x (pop sequence))) + (if (test olditem (key x)) + newitem + x))))) + (cond + ((and (not end) (not count)) + (do ((new-tail new-list (cdr new-tail))) + ((endp sequence) new-list) + (setf (cdr new-tail) (list #0#)))) + ((and end (not count)) + (do ((i (- end start) (1- i)) + (new-tail new-list (cdr new-tail))) + ((or (endp sequence) (<= i 0)) new-list) + (setf (cdr new-tail) (list #0#)))) + ((and (not end) count) + (do ((c 0) + (new-tail new-list (cdr new-tail))) + ((or (endp sequence) (>= c count)) + (setf (cdr new-tail) + (copy-list sequence)) + new-list) + (setf (cdr new-tail) #1=(list (let ((x (pop sequence))) + (if (test olditem (key x)) + (progn (incf c) newitem) + x)))))) + ((and end count) + (do ((i (- end start) (1- i)) + (c 0) + (new-tail new-list (cdr new-tail))) + ((or (endp sequence) (<= i 0) (>= c count)) + (setf (cdr new-tail) + (copy-list sequence)) + new-list) + (setf (cdr new-tail) #1#))) + ((error 'program-error)))))))))))) + +(defun nsubstitute (newitem olditem sequence &key (test 'eql) test-not (start 0) end count (key 'identity) from-end) + "=> sequence" + (when test-not + (setf test (complement test-not))) + (with-funcallable (test) + (with-funcallable (key) + (sequence-dispatch sequence + (vector + (let ((end (or end (length sequence)))) + (with-subvector-accessor (ref sequence start end) + (cond + ((and (not count) (not from-end)) + (do ((i start (1+ i))) + ((>= i end) sequence) + (when (test olditem (key (ref i))) + (setf (ref i) newitem)))) + ((and count (not from-end)) + (do ((c 0) + (i start (1+ i))) + ((>= i end) sequence) + (when (test olditem (key (ref i))) + (setf (ref i) newitem) + (when (>= (incf c) count) + (return sequence))))) + ((and (not count) from-end) + (do ((i (1- end) (1- i))) + ((< i start) sequence) + (when (test olditem (key (ref i))) + (setf (ref i) newitem)))) + ((and count from-end) + (do ((c 0) + (i (1- end) (1- i))) + ((< i start) sequence) + (when (test olditem (key (ref i))) + (setf (ref i) newitem) + (when (>= (incf c) count) + (return sequence))))) + ((error 'program-error)))))) + (list + (if from-end + (nreverse (nsubstitute newitem olditem (nreverse sequence) + :test test :test-not test-not + :start start :end end + :count count :key key)) + (let ((p (nthcdr start sequence))) + (cond + ((and (not end) (not count)) + (do ((p p (cdr p))) + ((endp p) sequence) + (when (test olditem (key (car p))) + (setf (car p) newitem)))) + ((and end (not count)) + (do ((i start (1+ i)) + (p p (cdr p))) + ((or (endp p) (>= i end)) sequence) + (when (test olditem (key (car p))) + (setf (car p) newitem)))) + ((and (not end) count) + (do ((c 0) + (p p (cdr p))) + ((endp p) sequence) + (when (test olditem (key (car p))) + (setf (car p) newitem) + (when (>= (incf c) count) + (return sequence))))) + ((and end count) + (do ((c 0) + (i start (1+ i)) + (p p (cdr p))) + ((or (endp p) (>= i end)) sequence) + (when (test olditem (key (car p))) + (setf (car p) newitem) + (when (>= (incf c) count) + (return sequence))))) + ((error 'program-error))))))))))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 21 Mar '06

21 Mar '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3269 Modified Files: basic-functions.lisp Log Message: Have apply check that the tail argument is a list. --- /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp 2005/08/26 19:39:20 1.20 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp 2006/03/21 20:20:20 1.21 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.20 2005/08/26 19:39:20 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.21 2006/03/21 20:20:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -229,7 +229,7 @@ (:jz 'more-than-three-args) no-more-args ;; Calculate numargs from (esp-ebp).. - (:leal (:ebp -8 8) :ecx) + (:leal (:ebp -8 8) :ecx) ; debugger also "knows" this offset.. (:subl :esp :ecx) (:shrl 2 :ecx) ;; Encode ECX @@ -258,8 +258,9 @@ ((null (cdr args)) (apply function (car args))) (t (let* ((second-last-cons (last args 2)) - (last-cons (cdr second-last-cons))) - (setf (cdr second-last-cons) (car last-cons)) + (tail (cadr second-last-cons))) + (check-type tail list) + (setf (cdr second-last-cons) tail) (apply function args))))))) (defun values (&rest objects)

1 0

[movitz-cvs] CVS movitz/losp/x86-pc
by ffjeld 21 Mar '06

21 Mar '06

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory clnet:/tmp/cvs-serv1496 Modified Files: debugger.lisp Log Message: Tweak backtrace to recognize an apply-frame's numargs. --- /project/movitz/cvsroot/movitz/losp/x86-pc/debugger.lisp 2005/08/31 22:34:58 1.41 +++ /project/movitz/cvsroot/movitz/losp/x86-pc/debugger.lisp 2006/03/21 20:13:12 1.42 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.41 2005/08/31 22:34:58 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.42 2006/03/21 20:13:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -49,7 +49,7 @@ (defvar *backtrace-do-conflate* t) (defvar *backtrace-length* 14) -(defvar *backtrace-max-args* 10) +(defvar *backtrace-max-args* 16) (defvar *backtrace-stack-frame-barrier* nil) (defvar *backtrace-do-fresh-lines* t) (defvar *backtrace-print-length* 3) @@ -158,6 +158,10 @@ ((and (= #x33 opcode0) (= #xc9 opcode1)) ;; XORL :ECX :ECX 0) + ((eq funobj #'apply) + (- (stack-frame-uplink stack frame) + frame + 2)) (t ;; now we should search further for where ecx may be set.. (format *debug-io* "{no ECX at ~D in ~S, opcode #x~X #x~X}" call-site funobj opcode0 opcode1) @@ -341,7 +345,7 @@ (#x52 (:set-result (-2))))))) (defun funobj-stack-frame-map (funobj &optional numargs) - "Try funobj's stack-frame map, which is a list that says + "Try to find funobj's stack-frame map, which is a list that says what the stack-frame contains at that position. Some funobjs' map depend on the number of arguments presented to it, so numargs can be provided for those cases."

1 0

[movitz-cvs] CVS movitz/losp
by ffjeld 17 Mar '06

17 Mar '06

Update of /project/movitz/cvsroot/movitz/losp In directory clnet:/tmp/cvs-serv7876 Modified Files: los0-gc.lisp Log Message: Let's get back on that horse.. real slow now.. --- /project/movitz/cvsroot/movitz/losp/los0-gc.lisp 2005/08/31 22:35:49 1.59 +++ /project/movitz/cvsroot/movitz/losp/los0-gc.lisp 2006/03/17 20:49:57 1.60 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.59 2005/08/31 22:35:49 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.60 2006/03/17 20:49:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -388,7 +388,7 @@ ((not (object-in-space-p oldspace x)) x) ((when (typep x 'run-time-context) - (warn "Scavengning ~S" x))) + (warn "Scavenging ~S" x))) (t (or (and (eq (object-tag x) (ldb (byte 3 0) (memref (object-location x) 0 :type :unsigned-byte8)))

1 0