movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 05 Apr '06

05 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3301 Modified Files: format.lisp Log Message: Support ~P and ~Newline. --- /project/movitz/cvsroot/movitz/losp/muerte/format.lisp 2005/08/26 19:39:06 1.12 +++ /project/movitz/cvsroot/movitz/losp/muerte/format.lisp 2006/04/05 23:02:22 1.13 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Mar 23 01:18:36 2002 ;;;; -;;;; $Id: format.lisp,v 1.12 2005/08/26 19:39:06 ffjeld Exp $ +;;;; $Id: format.lisp,v 1.13 2006/04/05 23:02:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -142,6 +142,24 @@ proceed (incf i) (case (char-upcase (schar control-string i)) + (#\Newline + (when at-sign-p + (write-char #\Newline)) + (unless colon-p + (do ((stop (1- (length control-string)))) + ((or (>= i stop) + (not (member (schar control-string (1+ i)) + '(#\space #\newline #\tab))))) + (incf i)))) + (#\P (let ((arg (if (not colon-p) + (pop args) + (car (nthcdr (1- (do ((i 0 (1+ i)) (p args-head (cdr p))) + ((eq p args) i) ; find arg's position in arg-head. + (assert p))) + args-head))))) + (write-string (if at-sign-p + (if (eql arg 1) "y" "ies") + (if (eql arg 1) "" "s"))))) (#\Z (if at-sign-p (print-word-indirect (pop args) nil) (print-word (pop args) nil)))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 03 Apr '06

03 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27835 Modified Files: defstruct.lisp Log Message: Added support for :copier option to defstruct. --- /project/movitz/cvsroot/movitz/losp/muerte/defstruct.lisp 2004/10/21 20:34:02 1.16 +++ /project/movitz/cvsroot/movitz/losp/muerte/defstruct.lisp 2006/04/03 21:22:39 1.17 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jan 22 13:10:59 2001 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defstruct.lisp,v 1.16 2004/10/21 20:34:02 ffjeld Exp $ +;;;; $Id: defstruct.lisp,v 1.17 2006/04/03 21:22:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -199,7 +199,9 @@ (default (:constructor) (intern (concatenate 'string (string 'make-) (string struct-name)))) (default (:predicate 1) - (intern (concatenate 'string (string struct-name) (string '-p))))) + (intern (concatenate 'string (string struct-name) (string '-p)))) + (default (:copier) + (intern (concatenate 'string (string 'copy-) (string struct-name))))) (let* ((struct-type (first (getf options :type))) (superclass (first (getf options :superclass))) (struct-named (first (getf options :named))) @@ -243,6 +245,11 @@ :type type :readonly read-only :location location)))) + ,@(loop for copier in (getf options :copier) + if (and copier (symbolp copier)) + collect + `(defun ,copier (x) + (copy-structure x))) ,@(loop for constructor in (getf options :constructor) if (and constructor (symbolp constructor)) collect

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 02 Apr '06

02 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv5418 Modified Files: sequences.lisp Log Message: Implemented reduce :from-end on lists. Improved remove-duplicates and delete-duplicates not to use O(n) stack. --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2006/03/25 20:59:16 1.31 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2006/04/02 20:48:34 1.32 @@ -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.31 2006/03/25 20:59:16 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.32 2006/04/02 20:48:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -126,8 +126,6 @@ (t (function sequence &key (key 'identity) from-end (start 0) (end (length sequence)) (initial-value nil initial-value-p)) - (when from-end - (error "REDUCE from-end is not implemented.")) (let ((start (check-the index start))) (with-funcallable (funcall-function function) (with-funcallable (key) @@ -140,18 +138,34 @@ (key (elt sequence start)))) (t (sequence-dispatch sequence (list - (do* ((counter (1+ start) (1+ counter)) - (list (nthcdr start sequence)) - (result (funcall-function (if initial-value-p - initial-value + (cond + ((not from-end) + (do* ((counter (1+ start) (1+ counter)) + (list (nthcdr start sequence)) + (result (funcall-function (if initial-value-p + initial-value + (key (pop list))) (key (pop list))) - (key (pop list))) - (funcall-function result (key (pop list))))) - ((or (null list) - (= end counter)) - result) - (declare (index counter)))) + (funcall-function result (key (pop list))))) + ((or (null list) + (= end counter)) + result) + (declare (index counter)))) + (from-end + (do* ((counter (1+ start) (1+ counter)) + (list (nreverse (subseq sequence start end))) + (result (funcall-function (key (pop list)) + (if initial-value-p + initial-value + (key (pop list)))) + (funcall-function (key (pop list)) result))) + ((or (null list) + (= end counter)) + result) + (declare (index counter)))))) (vector + (when from-end + (error "REDUCE from-end on vectors is not implemented.")) (with-subvector-accessor (sequence-ref sequence start end) (do* ((index start) (result (funcall-function (if initial-value-p @@ -731,7 +745,7 @@ (apply 'map-for-nil function first-sequence more-sequences)) ((eq 'list result-type) (apply 'map-for-list function first-sequence more-sequences)) - ((eq 'string result-type) + ((member result-type '(string simple-string)) (apply 'map-for-string function first-sequence more-sequences)) (t (error "MAP not implemented.")))) @@ -1390,21 +1404,17 @@ (setf test (complement test-not))) (sequence-dispatch sequence (list - (setf sequence (nthcdr start sequence)) - (when end (decf end start)) - (cond - ((endp sequence) - nil) - ((not from-end) - (let* ((new-end (when end (1- end))) - (tail (remove-duplicates (cdr sequence) :test test :key key :end new-end))) - (cond - ((find (car sequence) (cdr sequence) :test test :key key :end new-end) - tail) - ((eq tail (cdr sequence)) - sequence) - (t (cons (car sequence) tail))))) - (t (error "from-end not implemented.")))) + (let ((list (nthcdr start sequence))) + (cond + ((endp list) + nil) + ((and (not end) (not from-end)) + (do ((r nil)) + ((endp list) (nreverse r)) + (let ((x (pop list))) + (unless (member x list :key key :test test) + (push x r))))) + (t (error "remove-duplicates not implemented."))))) (vector (error "vector remove-duplicates not implemented."))))

1 0

[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

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs