movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[movitz-cvs] CVS movitz/ide
by ffjeld 09 Apr '07

09 Apr '07

Update of /project/movitz/cvsroot/movitz/ide In directory clnet:/tmp/cvs-serv15038 Modified Files: movitz-slime.el Log Message: Add movitz-disassemble-primitive. --- /project/movitz/cvsroot/movitz/ide/movitz-slime.el 2007/03/13 20:42:13 1.5 +++ /project/movitz/cvsroot/movitz/ide/movitz-slime.el 2007/04/09 16:00:00 1.6 @@ -45,7 +45,7 @@ ((slime-eval '(cl:and (cl:find-package :movitz.ide) t))) ((not (slime-eval '(cl:and (cl:find-package :movitz) t))) (message "Movitz-mode: The Movitz package is not loaded.")) - (t (slime-eval-async + (t (slime-eval `(cl:progn (cl:load (cl:compile-file ,(concat movitz-slime-path "ide.lisp"))) nil))))) @@ -161,27 +161,23 @@ (options options)) (cond ((string= "function" defun-type) - (message "Movitz disassembling %s %s..." defun-type defun-name) + (message "Movitz disassembling %s '%s'..." defun-type defun-name) (slime-eval-async `(movitz.ide:movitz-disassemble ,defun-name ,package-name) (lambda (result) (slime-show-description result package-name) - (message "Movitz disassembling %s %s...done." defun-type defun-name)))) + (message "Movitz disassembling %s '%s'...done." defun-type defun-name)))) ((string= "method" defun-type) (message "Movitz disassembling %s '%s %s'..." defun-type defun-name lambda-list) (slime-eval-async `(movitz.ide:movitz-disassemble-method ,defun-name ,lambda-list ',options ,package-name) (lambda (result) (slime-show-description result package-name) (message "Movitz disassembling %s '%s %s'...done." defun-type defun-name lambda-list)))) - ;; ((string= "primitive-function" defun-type) - ;; (message "Movitz disassembling %s %s..." defun-type defun-name) - ;; (fi:eval-in-lisp - ;; "(cl:let ((defun-name (cl:let ((cl:*package* (cl:find-package :%s))) - ;; (cl:read-from-string \"%s\"))) - ;; (cl:*print-base* 16)) - ;; (movitz::movitz-disassemble-primitive defun-name))" - ;; fi:package defun-name) - ;; (switch-to-buffer "*common-lisp*") - ;; (message "Movitz disassembling %s %s...done." defun-type defun-name)) + ((string= "primitive-function" defun-type) + (message "Movitz disassembling %s '%s'..." defun-type defun-name) + (slime-eval-async `(movitz.ide:movitz-disassemble-primitive ,defun-name ,package-name) + (lambda (result) + (slime-show-description result package-name) + (message "Movitz disassembling %s '%s'...done." defun-type defun-name)))) (t (message "Don't know how to Movitz disassemble %s '%s'." defun-type defun-name)))))) (defun movitz-arglist (string)

1 0

[movitz-cvs] CVS movitz/ide
by ffjeld 09 Apr '07

09 Apr '07

Update of /project/movitz/cvsroot/movitz/ide In directory clnet:/tmp/cvs-serv14958 Modified Files: ide.lisp Log Message: Add movitz-disassemble-primitive. --- /project/movitz/cvsroot/movitz/ide/ide.lisp 2007/03/13 20:42:11 1.6 +++ /project/movitz/cvsroot/movitz/ide/ide.lisp 2007/04/09 15:59:43 1.7 @@ -13,6 +13,7 @@ #:compile-defun #:dump-image #:movitz-disassemble + #:movitz-disassemble-primitive #:movitz-disassemble-method #:movitz-arglist #:movitz-macroexpand)) @@ -49,6 +50,13 @@ (movitz:movitz-disassemble (get-sexpr printname (get-package package-printname)))))) +(defun movitz-disassemble-primitive (printname package-printname) + "Return the disassembly of SYMBOL-NAME's function as a string." + (with-image () + (with-output-to-string (*standard-output*) + (movitz::movitz-disassemble-primitive (get-sexpr printname + (get-package package-printname)))))) + (defun movitz-disassemble-method (gf-name lambda-list qualifiers package-name) (with-image () (let ((package (get-package package-name)))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 08 Apr '07

08 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv19367 Modified Files: arrays.lisp Log Message: Remove lingering debug statement. --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/04/08 15:52:33 1.63 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/04/08 16:03:53 1.64 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.63 2007/04/08 15:52:33 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.64 2007/04/08 16:03:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1100,7 +1100,6 @@ (do-it)))) (cond ((integerp fill-pointer) - (warn "sfp len: ~s" (array-dimension array 0)) (setf (fill-pointer array) fill-pointer)) ((or (eq t fill-pointer) (array-has-fill-pointer-p array))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 08 Apr '07

08 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16794 Modified Files: arrays.lisp Log Message: Fixed a stupid bug in (setf fill-pointer) which made make-array fail on vectors of length between #x1000 and #x4000. --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/04/07 20:18:20 1.62 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/04/08 15:52:33 1.63 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.62 2007/04/07 20:18:20 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.63 2007/04/08 15:52:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -157,7 +157,7 @@ "Does the basic-vector have a fill-pointer?" `(with-inline-assembly (:returns :boolean-zf=1) (:compile-form (:result-mode :eax) ,vector) - (:testl ,(logxor #xffffffff (1- (expt 2 14))) + (:testl ,(logxor #xffffffff (* movitz:+movitz-fixnum-factor+ (1- (expt 2 14)))) (:eax ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))))) (define-compiler-macro %basic-vector-fill-pointer (vector) @@ -232,7 +232,8 @@ (:jnz 'illegal-fill-pointer) (:movl (:ebx (:offset movitz-basic-vector num-elements)) :ecx) - (:testl ,(logxor #xffffffff (1- (expt 2 14))) :ecx) + (:testl ,(logxor #xffffffff (* movitz:+movitz-fixnum-factor+ (1- (expt 2 14)))) + :ecx) (:jnz '(:sub-program () (:compile-form (:result-mode :ignore) (error "Vector has no fill-pointer.")))) @@ -1099,6 +1100,7 @@ (do-it)))) (cond ((integerp fill-pointer) + (warn "sfp len: ~s" (array-dimension array 0)) (setf (fill-pointer array) fill-pointer)) ((or (eq t fill-pointer) (array-has-fill-pointer-p array))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 08 Apr '07

08 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27055 Modified Files: ratios.lisp Log Message: Add some silly and slow cos and sin functions. --- /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp 2007/03/16 19:49:24 1.9 +++ /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp 2007/04/08 13:44:44 1.10 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 20 00:39:59 2004 ;;;; -;;;; $Id: ratios.lisp,v 1.9 2007/03/16 19:49:24 ffjeld Exp $ +;;;; $Id: ratios.lisp,v 1.10 2007/04/08 13:44:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -76,9 +76,28 @@ (integer 1) (ratio (%ratio-denominator x)))) -(defconstant pi #xea7632a/4aa1a8b) - (defconstant least-positive-short-float 1/1000) (defconstant least-positive-single-float 1/1000) (defconstant least-positive-double-float 1/1000) (defconstant least-positive-long-float 1/1000) + +;;; + +(defconstant pi #xea7632a/4aa1a8b) + +(defvar long-float-epsilon 1/10000) + +(defun cos (x) + "http://mathworld.wolfram.com/Cosine.html" + (do* ((rad (mod x 44/7)) + (n2 0 (+ n2 2)) + (sign 1 (- sign)) + (denominator 1 (* denominator (1- n2) n2)) + (term 1 (/ (expt rad n2) + denominator)) + (sum 1 (+ sum (* sign term)))) + ((<= term long-float-epsilon) + sum))) + +(defun sin (x) + (cos (- x (/ pi 2))))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 08 Apr '07

08 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv22352 Modified Files: format.lisp Log Message: Format-float was completely broken: It tried to round off when printing the last digit, but that must be done initially, in case of "overflow". --- /project/movitz/cvsroot/movitz/losp/muerte/format.lisp 2007/02/11 21:57:14 1.15 +++ /project/movitz/cvsroot/movitz/losp/muerte/format.lisp 2007/04/08 13:14:58 1.16 @@ -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.15 2007/02/11 21:57:14 ffjeld Exp $ +;;;; $Id: format.lisp,v 1.16 2007/04/08 13:14:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -68,24 +68,22 @@ ((minusp x) (write-char #\-) (format-float (- x) at-sign-p colon-p w d k overflowchar padchar)) - (t (multiple-value-bind (integer-part decimal-part) - (truncate x) - (write-integer integer-part *standard-output* 10 nil) - (dotimes (i k) - (write-char #\0)) - (write-char #\.) - (do ((remainder decimal-part) - (last-i (if d (1- d) 15)) - (i 0 (1+ i))) - ((or (and (not d) (plusp i) (zerop remainder)) - (> i last-i))) - (declare (index i)) - (multiple-value-bind (next-digit next-remainder) - (if (= i last-i) - (floor (+ 1/2 (* 10 remainder))) - (truncate (* 10 remainder))) - (setf remainder next-remainder) - (write-digit next-digit *standard-output*))))))) + (t (let ((decimals (if d (1- d) 15))) + (multiple-value-bind (integer-part decimal-part) + (truncate (+ x (* 1/20 (expt 1/10 decimals)))) + (write-integer integer-part *standard-output* 10 nil) + (dotimes (i k) + (write-char #\0)) + (write-char #\.) + (do ((remainder decimal-part) + (i 0 (1+ i))) + ((or (and (not d) (plusp i) (zerop remainder)) + (> i decimals))) + (declare (index i)) + (multiple-value-bind (next-digit next-remainder) + (truncate (* 10 remainder)) + (setf remainder next-remainder) + (write-digit next-digit *standard-output*)))))))) (defun find-directive (string i directive &optional recursive-skip-start (recursive-skip-end directive))

1 0

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

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv31071 Modified Files: scavenge.lisp Log Message: Improved format-strings in map-header-vals. --- /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2007/04/05 21:12:19 1.60 +++ /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2007/04/07 20:50:38 1.61 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.60 2007/04/05 21:12:19 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.61 2007/04/07 20:50:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -67,7 +67,7 @@ (let ((x (memref scan 0 :type :unsigned-byte16)) (x2 (memref scan 2 :type :unsigned-byte16))) (when verbose - (format *terminal-io* " [at ~S: ~S]" scan x)) + (format *terminal-io* " [at #x~X: #x~X]" scan x)) (cond ((let ((tag (ldb (byte 3 0) x))) (or (= tag #.(movitz:tag :null)) @@ -78,10 +78,10 @@ (and (= #xffff x2) (= #xfffe x)) (and (= #x7fff x2) (= #xffff x)))) ((scavenge-typep x :illegal) - (error "Illegal word ~S at ~S." x scan)) + (error "Illegal word #x~4,'0X at #x~X." x scan)) ((scavenge-typep x :bignum) (assert (evenp scan) () - "Scanned bignum-header ~S at odd location #x~X." x scan) + "Scanned bignum-header #x~4,'0X at odd location #x~X." x scan) ;; Just skip the bigits (let* ((bigits (memref scan 0 :index 1 :type :unsigned-byte14)) (delta (logior bigits 1))) @@ -89,11 +89,11 @@ (incf scan delta))) ((scavenge-typep x :defstruct) (assert (evenp scan) () - "Scanned struct-header ~S at odd location #x~X." x scan) + "Scanned struct-header #x~4,'0X at odd location #x~X." x scan) (record-scan (%word-offset scan #.(movitz:tag :other)))) ((scavenge-typep x :run-time-context) (assert (evenp scan) () - "Scanned run-time-context-header ~S at odd location #x~X." + "Scanned run-time-context-header #x~4,'0X at odd location #x~X." (memref scan 0 :type :unsigned-byte32) scan) (incf scan) (let ((non-lispvals #.(cl:truncate (cl:+ -4 (bt:slot-offset 'movitz::movitz-run-time-context @@ -106,7 +106,7 @@ (setf scan end))) ((scavenge-typep x :funobj) (assert (evenp scan) () - "Scanned funobj-header ~S at odd location #x~X." + "Scanned funobj-header #x~4,'0X at odd location #x~X." (memref scan 0 :type :unsigned-byte32) scan) (record-scan (%word-offset scan #.(movitz:tag :other))) ;; Process code-vector pointers specially.. @@ -157,11 +157,11 @@ (incf scan num-jumpers)))))) ((scavenge-typep x :infant-object) (assert (evenp scan) () - "Scanned infant ~S at odd location #x~X." x scan) - (error "Scanning an infant object ~Z at ~S (end ~S)." x scan end-location)) + "Scanned infant #x~4,'0X at odd location #x~X." x scan) + (error "Scanning an infant object #x~4,'0X at #x~X (end #x~X)." x scan end-location)) ((scavenge-typep x :basic-vector) (assert (evenp scan) () - "Scanned basic-vector-header ~S at odd location #x~X." x scan) + "Scanned basic-vector-header #x~4,'0X at odd location #x~X." x scan) (cond ((or (scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u8)) @@ -191,7 +191,7 @@ #.(bt:enum-value 'movitz:movitz-vector-element-type :indirects))) (record-scan (%word-offset scan #.(movitz:tag :other)))) - (t (error "Scanned unknown basic-vector-header ~S at location #x~X." x scan)))) + (t (error "Scanned unknown basic-vector-header #x~4,'0X at location #x~X." x scan)))) ((and (eq x 3) (eq x2 0)) (record-scan scan) (incf scan) @@ -202,9 +202,9 @@ (t ;; (typep x 'pointer) (let* ((old (memref scan 0)) (new (funcall function old scan))) - (when verbose - (format *terminal-io* " [~Z => ~Z]" old new)) (unless (eq old new) + (when verbose + (format *terminal-io* " [~Z => ~Z]" old new)) (setf (memref scan 0) new)))))))) (values))

1 0

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

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv30506 Modified Files: interrupt.lisp Log Message: Improved error decoding for exception 69. --- /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2007/03/26 21:11:43 1.55 +++ /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2007/04/07 20:49:17 1.56 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.55 2007/03/26 21:11:43 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.56 2007/04/07 20:49:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -342,10 +342,15 @@ $eip $eax $ebx $ecx $edx) (dotimes (i 100000) (with-inline-assembly (:returns :nothing) (:nop)))) - (69 (error 'type-error - :datum (dereference $eax) - :expected-type (aref #(cons function) - (dereference $ecx :unsigned-byte8)))) + (69 (let ((expected-type + (aref #(cons function) + (dereference $ecx :unsigned-byte8)))) + (error 'type-error + :datum (case expected-type + (function + (dereference $edx)) + (t (dereference $eax))) + :expected-type expected-type))) (70 (error "Unaligned memref access.")) ((5 55) (let* ((old-bottom (prog1 (%run-time-context-slot nil 'stack-bottom)

1 0

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

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv25962 Modified Files: arrays.lisp Log Message: make-basic-vector%t used to have an atomic-sequence that was O(N) to the length of the vector. Consequently, with somewhat frequent interrupts and a slightly large N, this sequence would never reach completion. Lesson is, atomic sequences must be O(1). --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/03/11 22:41:45 1.61 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/04/07 20:18:20 1.62 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.61 2007/03/11 22:41:45 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.62 2007/04/07 20:18:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1040,36 +1040,75 @@ (defun make-basic-vector%t (length fill-pointer initial-element initial-contents) (check-type length (and fixnum (integer 0 *))) - (let* ((words (+ 2 length)) - (array (macrolet - ((do-it () - `(with-allocation-assembly (words :fixed-size-p t - :object-register :eax) - (:load-lexical (:lexical-binding length) :ecx) - (:movl ,(movitz:basic-vector-type-tag :any-t) - (:eax (:offset movitz-basic-vector type))) - (:movl :ecx (:eax (:offset movitz-basic-vector num-elements))) - (:addl 4 :ecx) - (:andl -8 :ecx) - (:jz 'init-done) - (:load-lexical (:lexical-binding initial-element) :edx) - init-loop - (:movl :edx (:eax (:offset movitz-basic-vector data) :ecx -4)) - (:subl 4 :ecx) - (:jnz 'init-loop) - init-done - ))) - (do-it)))) + (let* ((words (+ 2 length))) (cond - ((integerp fill-pointer) - (setf (fill-pointer array) fill-pointer)) - ((or (eq t fill-pointer) - (array-has-fill-pointer-p array)) - (setf (fill-pointer array) length))) - (cond - (initial-contents - (replace array initial-contents))) - array)) + ((<= length 8) + (let ((array (macrolet + ((do-it () + `(with-allocation-assembly (words :fixed-size-p t + :object-register :eax) + (:load-lexical (:lexical-binding length) :ecx) + (:movl ,(movitz:basic-vector-type-tag :any-t) + (:eax (:offset movitz-basic-vector type))) + (:movl :ecx (:eax (:offset movitz-basic-vector num-elements))) + (:addl 4 :ecx) + (:andl -8 :ecx) + (:jz 'init-done) + (:load-lexical (:lexical-binding initial-element) :edx) + init-loop + (:movl :edx (:eax (:offset movitz-basic-vector data) :ecx -4)) + (:subl 4 :ecx) + (:jnz 'init-loop) + init-done + ))) + (do-it)))) + (cond + ((integerp fill-pointer) + (setf (fill-pointer array) fill-pointer)) + ((or (eq t fill-pointer) + (array-has-fill-pointer-p array)) + (setf (fill-pointer array) length))) + (when initial-contents + (replace array initial-contents)) + array)) + (t (let* ((init-word (if (typep initial-element '(or null fixnum character)) + initial-element + nil)) + (array (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) + (with-non-pointer-allocation-assembly (words :fixed-size-p t + :object-register :eax) + (:load-lexical (:lexical-binding length) :ecx) + (:movl ,(movitz:basic-vector-type-tag :u32) + (:eax (:offset movitz-basic-vector type))) + (:movl :ecx (:eax (:offset movitz-basic-vector num-elements))))) + (:load-lexical (:lexical-binding length) :ecx) + (:addl 4 :ecx) + (:andl -8 :ecx) + (:jz 'init-done2) + (:load-lexical (:lexical-binding init-word) :edx) + init-loop2 + (:movl :edx (:eax (:offset movitz-basic-vector data) :ecx -4)) + (:subl 4 :ecx) + (:jnz 'init-loop2) + init-done2 + (:movl ,(movitz:basic-vector-type-tag :any-t) + (:eax (:offset movitz-basic-vector type)))))) + (do-it)))) + (cond + ((integerp fill-pointer) + (setf (fill-pointer array) fill-pointer)) + ((or (eq t fill-pointer) + (array-has-fill-pointer-p array)) + (setf (fill-pointer array) length))) + (cond + (initial-contents + (replace array initial-contents)) + ((not (eq init-word initial-element)) + (fill array initial-element))) + array))))) (defun make-indirect-vector (displaced-to displaced-offset fill-pointer length) (let ((x (make-basic-vector%t 4 0 nil nil)))

1 0

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

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv25634 Modified Files: sequences.lisp Log Message: Fix nsubstitute-if for :from-end t. Previously it could spin eternally. --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2007/04/07 07:59:31 1.36 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2007/04/07 20:14:45 1.37 @@ -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.36 2007/04/07 07:59:31 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.37 2007/04/07 20:14:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1886,90 +1886,97 @@ (defun nsubstitute-if (newitem predicate sequence &key (start 0) end count (key 'identity) from-end) "=> sequence" - (with-funcallable (predicate) - (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) - (declare (index 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) - (declare (index i c)) - (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) - (declare (index 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) - (declare (index c i)) - (when (predicate (key (ref i))) - (setf (ref i) newitem) - (when (>= (incf c) count) - (return sequence))))) - ((error 'program-error)))))) - (list - (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) - (declare (index i)) - (when (predicate (key (car p))) - (incf i)) - (setf p (cdr p)))) - (cond - ((and (not end) (not count)) - (do ((p p (cdr p))) - ((endp p) sequence) - (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) - (declare (index i)) - (when (predicate (key (car p))) - (setf (car p) newitem)))) - ((and (not end) count) - (do ((c 0) - (p p (cdr p))) - ((endp p) sequence) - (declare (index c)) - (when (predicate (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) - (declare (index c i)) - (when (predicate (key (car p))) - (setf (car p) newitem) - (when (>= (incf c) count) - (return sequence))))) - ((error 'program-error)))))))))) + (if (<= count 0) + sequence + (with-funcallable (predicate) + (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) + (declare (index 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) + (declare (index i c)) + (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) + (declare (index 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) + (declare (index c i)) + (when (predicate (key (ref i))) + (setf (ref i) newitem) + (when (>= (incf c) count) + (return sequence))))) + ((error 'program-error)))))) + (list + (let ((p (nthcdr start sequence))) + (cond + (from-end + (nreverse (nsubstitute-if newitem predicate (nreverse sequence) + :start (if (not end) 0 (- (length sequence) end)) + :end (if (plusp start) nil (- (length sequence) start)) + :count count :key key))) + #+ignore ((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) + (declare (index i)) + (when (predicate (key (car p))) + (incf i)) + (setf p (cdr p))))) + ((and (not end) (not count)) + (do ((p p (cdr p))) + ((endp p) sequence) + (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) + (declare (index i)) + (when (predicate (key (car p))) + (setf (car p) newitem)))) + ((and (not end) count) + (do ((c 0) + (p p (cdr p))) + ((endp p) sequence) + (declare (index c)) + (when (predicate (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) + (declare (index c i)) + (when (predicate (key (car p))) + (setf (car p) newitem) + (when (>= (incf c) count) + (return sequence))))) + ((error 'program-error)))))))))) (defun nsubstitute-if-not (newitem predicate sequence &rest keyargs) (declare (dynamic-extent keyargs))

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