movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[movitz-cvs] CVS update: movitz/losp/los0.lisp
by Frode Vatvedt Fjeld 31 Mar '04

31 Mar '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv29536 Modified Files: los0.lisp Log Message: Improved :decimal top-level command. Date: Wed Mar 31 11:37:13 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.8 movitz/losp/los0.lisp:1.9 --- movitz/losp/los0.lisp:1.8 Mon Mar 29 09:36:15 2004 +++ movitz/losp/los0.lisp Wed Mar 31 11:37:13 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.8 2004/03/29 14:36:15 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.9 2004/03/31 16:37:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -680,25 +680,21 @@ (define-toplevel-command :decimal (&optional x-list) (flet ((do-print (x) (typecase x - #+ignore - (float - (format t "~&~W ~~ ~,3F" x x)) (number (case *print-base* (16 (format t "~&~W = ~D" x x)) (10 (format t "~&~W = #x~X" x x)) (t (format t "~&~W = ~D. = #x~X" x x x))) - #+ignore (when (typep x 'ratio) (format t " ~~ ~,3F" x))) - (t (fresh-line) - (write x :radix nil :base (case *print-base* (10 16) (t 10))))) + (pointer + (format t "~&~Z = ~W" x x)) + (t (write x :radix nil :base (case *print-base* (10 16) (t 10))))) x)) (if x-list (do-print (eval x-list)) (dolist (x cl:/ (values-list cl:/)) - (do-print x)))) - (values)) + (do-print x))))) (define-toplevel-command :pop () (when *debugger-dynamic-context*

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp
by Frode Vatvedt Fjeld 31 Mar '04

31 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27446 Modified Files: scavenge.lisp Log Message: The scavenging mapper function now also passes the referring location as an argument to the mapped function. Date: Wed Mar 31 11:36:34 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.2 movitz/losp/muerte/scavenge.lisp:1.3 --- movitz/losp/muerte/scavenge.lisp:1.2 Tue Mar 30 03:50:12 2004 +++ movitz/losp/muerte/scavenge.lisp Wed Mar 31 11:36:34 2004 @@ -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.2 2004/03/30 08:50:12 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.3 2004/03/31 16:36:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -31,7 +31,6 @@ (defun map-heap-words (function start-location end-location) "Map function over each potential pointer word between start-location and end-location." - (check-type start-location fixnum) (macrolet ((scavenge-typep (x primary) (let ((code (movitz:tag primary))) `(with-inline-assembly (:returns :boolean-zf=1) @@ -44,51 +43,50 @@ `(with-inline-assembly (:returns :boolean-zf=1) (:compile-form (:result-mode :eax) ,x) (:cmpw ,code :ax))))) - (do ((i start-location (1+ i))) - ((>= i end-location)) - (let ((*i* i) - (x (memref i 0 0 :lisp))) - (declare (special *i*)) + (do ((scan start-location (1+ scan))) + ((>= scan end-location)) + (let (;; (*i* i) + (x (memref scan 0 0 :lisp))) + ;; (declare (special *i*)) (cond ((typep x '(or null fixnum character))) ((scavenge-typep x :illegal) - (error "Illegal word ~Z at ~S." x i)) + (error "Illegal word ~Z at ~S." x scan)) ((scavenge-typep x :funobj) ;; Process code-vector pointer specially.. - (let ((code-vector (%word-offset (memref i 0 -1 :lisp) -2)) - (num-jumpers (ldb (byte 14 0) (memref i 0 6 :lisp)))) + (let ((code-vector (%word-offset (memref scan 0 -1 :lisp) -2)) + (num-jumpers (ldb (byte 14 0) (memref scan 0 6 :lisp)))) (check-type code-vector vector-u8) - (map-heap-words function (+ i 4) (+ i 6)) ; scan funobj's lambda-list and name fields - (let ((new-code-vector (funcall function code-vector))) + (map-heap-words function (+ scan 4) (+ scan 6)) ; scan funobj's lambda-list and name fields + (let ((new-code-vector (funcall function code-vector scan))) (check-type new-code-vector vector-u8) (unless (eq code-vector new-code-vector) (error "Code-vector migration is not implemented.") - (setf (memref i 0 -1 :lisp) (%word-offset new-code-vector 2)) + (setf (memref scan 0 -1 :lisp) (%word-offset new-code-vector 2)) ;; Do more stuff here to update code-vectors and jumpers )) - (incf i (+ 6 num-jumpers)))) ; Don't scan the jumpers. + (incf scan (+ 6 num-jumpers)))) ; Don't scan the jumpers. ((scavenge-typep x :infant-object) - (error "Scanning an infant object ~Z at ~S." x i)) + (error "Scanning an infant object ~Z at ~S." x scan)) ((or (scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u8)) (scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :character))) - (let ((len (memref i -2 0 :unsigned-byte16))) - (incf i (* 2 (truncate (+ 7 len) 8))))) + (let ((len (memref scan -2 0 :unsigned-byte16))) + (incf scan (* 2 (truncate (+ 7 len) 8))))) ((scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16)) - (let ((len (memref i -2 0 :unsigned-byte16))) - (incf i (* 2 (truncate (+ 3 len) 4))))) + (let ((len (memref scan -2 0 :unsigned-byte16))) + (incf scan (* 2 (truncate (+ 3 len) 4))))) ((scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32)) - (let ((len (memref i -2 0 :unsigned-byte16))) - (incf i (* 2 (truncate (+ 1 len) 2))))) + (let ((len (memref scan -2 0 :unsigned-byte16))) + (incf scan (* 2 (truncate (+ 1 len) 2))))) ((eq x (fixnum-word 3)) - (incf i) - (incf i (memref i 0 0 :lisp))) + (incf scan) + (incf scan (memref scan 0 0 :lisp))) ((typep x 'pointer) - (let ((new (funcall function x))) - (check-type new pointer) - (unless (eq x new) - (setf (memref i 0 0 :lisp) new)))))))) + (let ((new (funcall function x scan))) + (unless (eq new x) + (setf (memref scan 0 0 :lisp) new)))))))) (values)) (defun map-stack-words (function start-stack-frame)

1 0

[movitz-cvs] CVS update: movitz/losp/los0-gc.lisp
by Frode Vatvedt Fjeld 31 Mar '04

31 Mar '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv26945 Modified Files: los0-gc.lisp Log Message: The scavenging mapper function now also passes the referring location as an argument to the mapped function. Date: Wed Mar 31 11:36:29 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.1 movitz/losp/los0-gc.lisp:1.2 --- movitz/losp/los0-gc.lisp:1.1 Mon Mar 29 09:35:45 2004 +++ movitz/losp/los0-gc.lisp Wed Mar 31 11:36:29 2004 @@ -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.1 2004/03/29 14:35:45 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.2 2004/03/31 16:36:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -139,18 +139,25 @@ (+ (object-location space) (array-dimension space 0))))) -(defun report-nursery (x) +(defun report-nursery (x location) "Write a message if x is inside newspace." (when (object-in-space-p (%run-time-context-slot 'nursery-space) x) - (format t "~&~Z: ~S: ~S" x (type-of x) x)) + (format t "~&~Z: ~S: ~S from ~S" x (type-of x) x location)) x) -(defun report-inactive-space (x) +(defun report-inactive-space (x location) "Check that x is not pointing into (what is presumably) oldspace." (when (object-in-space-p (space-other (%run-time-context-slot 'nursery-space)) x) - (break "~Z: ~S: ~S" x (type-of x) x)) + (break "~Z: ~S: ~S from ~S" x (type-of x) x location)) x) +(defun location-finder (find-location) + (lambda (x location) + (when (location-in-object-p x find-location) + (break "The location ~S is in the object at ~Z referenced from location ~S." + find-location x location)) + x)) + (defun stop-and-copy () (let* ((space0 (%run-time-context-slot 'nursery-space)) (space1 (space-other space0))) @@ -164,9 +171,11 @@ (values space1 space0)) ;; Ensure newspace is activated. (setf (%run-time-context-slot 'nursery-space) newspace) + ;; (assert (< #x200 (- (length newspace) (space-fresh-pointer newspace)))) ;; Evacuate-oldspace is to be mapped over every potential pointer. - (flet ((evacuate-oldspace (x) + (flet ((evacuate-oldspace (x location) "If x is in oldspace, migrate it to newspace." + (declare (ignore location)) (if (not (object-in-space-p oldspace x)) x (let ((forwarded-x (memref (object-location x) 0 1 :lisp)))

1 0

[movitz-cvs] CVS update: movitz/stream-image.lisp
by Frode Vatvedt Fjeld 31 Mar '04

31 Mar '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv15585 Modified Files: stream-image.lisp Log Message: Be slightly more clever about guessing a nil-word for stream-images. Date: Wed Mar 31 11:34:48 2004 Author: ffjeld Index: movitz/stream-image.lisp diff -u movitz/stream-image.lisp:1.3 movitz/stream-image.lisp:1.4 --- movitz/stream-image.lisp:1.3 Mon Feb 9 19:23:39 2004 +++ movitz/stream-image.lisp Wed Mar 31 11:34:47 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Aug 27 14:46:50 2001 ;;;; -;;;; $Id: stream-image.lisp,v 1.3 2004/02/10 00:23:39 ffjeld Exp $ +;;;; $Id: stream-image.lisp,v 1.4 2004/03/31 16:34:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -31,7 +31,11 @@ :reader image-start-address) (nil-word :initarg :nil-word - :initform #x65 + :initform (if (boundp '*image*) + (image-nil-word *image*) + (progn + (format *query-io* "~&Please enter the stream-images NIL value: ") + (read *query-io*))) :reader image-nil-word))) (defmethod image-register32 ((image stream-image) register-name)

1 0

[movitz-cvs] CVS update: movitz/special-operators.lisp
by Frode Vatvedt Fjeld 31 Mar '04

31 Mar '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv2537 Modified Files: special-operators.lisp Log Message: Minor edits. Date: Wed Mar 31 11:33:25 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.16 movitz/special-operators.lisp:1.17 --- movitz/special-operators.lisp:1.16 Sun Mar 28 11:20:05 2004 +++ movitz/special-operators.lisp Wed Mar 31 11:33:25 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.16 2004/03/28 16:20:05 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.17 2004/03/31 16:33:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -377,7 +377,7 @@ :muerte.cl :cl)) (cl-macro-body (translate-program macro-body :muerte.cl :cl))) (when (member name (image-called-functions *image*) :key #'first) - #+ignore (warn "Macro ~S defined after being called as function (in ~S)." + #+ignore (warn "Macro ~S defined after being called as function (first in ~S)." name (cdr (find name (image-called-functions *image*) :key #'first)))) (multiple-value-bind (cl-body declarations doc-string) @@ -427,7 +427,7 @@ (env-formal (or envvar (gensym))) (expansion-var (gensym))) (when (member operator-name (image-called-functions *image*) :key #'first) - (warn "Compiler-macro ~S defined after being called as function (in ~S)" + (warn "Compiler-macro ~S defined after being called as function (first in ~S)" operator-name (cdr (find operator-name (image-called-functions *image*) :key #'first)))) (let ((expander @@ -572,7 +572,7 @@ (destructuring-bind (var) (cdr expr) (let ((binding (movitz-binding var env))) - (check-type binding lexical-binding) + (check-type binding binding) (list binding))))) (let ((code (assembly-macroexpand inline-asm amenv))) #+ignore @@ -686,7 +686,7 @@ `((:cmpl :edi ,(single-value-register not-returns)))) :returns :boolean-zf=1)) ; TRUE iff result equal to :edi/NIL. (otherwise - (warn "unable to deal inteligently with inlined-NOT not-returns: ~S for ~S from ~S" + (warn "unable to deal intelligently with inlined-NOT not-returns: ~S for ~S from ~S" not-returns not-result-mode (not-values :producer)) (let ((label (make-symbol "not-label"))) (compiler-values (not-values) @@ -711,9 +711,9 @@ as sub-form-result-mode = buried-result-modes then (or (cdr sub-form-result-mode) sub-form-result-mode) - as current-result-mode = (if (endp (cdr sub-form)) - ;; all but the last form have - ;; result-mode as declared + as current-result-mode = (if (endp (cdr sub-form)) all but the + ;; last form have result-mode as + ;; declared result-mode (car sub-form-result-mode)) as last-form-p = (endp (cdr sub-form))

1 0

[movitz-cvs] CVS update: movitz/packages.lisp
by Frode Vatvedt Fjeld 31 Mar '04

31 Mar '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29110 Modified Files: packages.lisp Log Message: Added symbol. Date: Wed Mar 31 11:32:22 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.11 movitz/packages.lisp:1.12 --- movitz/packages.lisp:1.11 Mon Mar 29 09:36:43 2004 +++ movitz/packages.lisp Wed Mar 31 11:32:22 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.11 2004/03/29 14:36:43 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.12 2004/03/31 16:32:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1322,6 +1322,7 @@ #:*compiler-global-segment-prefix* #:*compiler-compile-eval-whens* #:*compiler-compile-macro-expanders* + #:*compiler-allow-untagged-word-bits* ) (:import-from muerte #:translate-program

1 0

[movitz-cvs] CVS update: movitz/eval.lisp
by Frode Vatvedt Fjeld 31 Mar '04

31 Mar '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv28070 Modified Files: eval.lisp Log Message: Have movitz-constantp and movitz-eval understand +, -, and *. Date: Wed Mar 31 11:31:44 2004 Author: ffjeld Index: movitz/eval.lisp diff -u movitz/eval.lisp:1.3 movitz/eval.lisp:1.4 --- movitz/eval.lisp:1.3 Thu Mar 25 20:43:46 2004 +++ movitz/eval.lisp Wed Mar 31 11:31:44 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 2 17:45:05 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: eval.lisp,v 1.3 2004/03/26 01:43:46 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.4 2004/03/31 16:31:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -66,8 +66,13 @@ (symbol (or (movitz-env-get form 'constantp nil environment) (typep (movitz-binding form environment) 'constant-object-binding))) (cons (case (car form) - ((muerte.cl::quote) t) - (muerte.cl::not (movitz-constantp (second form)))))))) + ((muerte.cl:quote) t) + ((muerte.cl:not) + (movitz-constantp (second form))) + ((muerte.cl:+ muerte.cl:- muerte.cl:*) + (every (lambda (sub-form) + (movitz-constantp sub-form environment)) + (cdr form)))))))) (defun isconst (x) @@ -139,4 +144,9 @@ (eval-self-evaluating (second form) env top-level-p)) (muerte.cl::not (not (eval-form (second form) env nil))) + ((muerte.cl:+ muerte.cl:- muerte.cl:*) + (apply (translate-program (car form) :muerte.cl :cl) + (mapcar (lambda (sub-form) + (movitz-eval sub-form env nil)) + (cdr form)))) (t (error "Don't know how to compile constant compound form ~A" form))))

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by Frode Vatvedt Fjeld 31 Mar '04

31 Mar '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv15542 Modified Files: compiler.lisp Log Message: Added variable *compiler-allow-untagged-word-bits* (see docstring). Date: Wed Mar 31 10:55:31 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.38 movitz/compiler.lisp:1.39 --- movitz/compiler.lisp:1.38 Tue Mar 30 14:23:40 2004 +++ movitz/compiler.lisp Wed Mar 31 10:55:31 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.38 2004/03/30 19:23:40 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.39 2004/03/31 15:55:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -43,6 +43,12 @@ (defvar *compiler-global-segment-prefix* nil "Use these assembly-instruction prefixes when accessing the global run-time context.") + +(defvar *compiler-allow-untagged-word-bits* 0 + "Allow (temporary) untagged values of this bit-size to exist, because +the system ensures one way or another that there can be no pointers below +this size.") + (defvar *compiler-compile-eval-whens* t "When encountering (eval-when (:compile-toplevel) <code>),

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp
by Frode Vatvedt Fjeld 31 Mar '04

31 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17089 Modified Files: sequences.lisp Log Message: Added two-arguments implementations for find and count-if. Date: Wed Mar 31 07:17:19 2004 Author: ffjeld Index: movitz/losp/muerte/sequences.lisp diff -u movitz/losp/muerte/sequences.lisp:1.5 movitz/losp/muerte/sequences.lisp:1.6 --- movitz/losp/muerte/sequences.lisp:1.5 Sun Feb 29 14:14:59 2004 +++ movitz/losp/muerte/sequences.lisp Wed Mar 31 07:17:14 2004 @@ -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.5 2004/02/29 19:14:59 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.6 2004/03/31 12:17:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -775,35 +775,50 @@ sequence-1))) (defun find (item sequence &key from-end (test 'eql) (start 0) end (key 'identity)) - (with-funcallable (test) - (with-funcallable (key) + (numargs-case + (2 (item sequence) (sequence-dispatch sequence (vector - (setf end (or end (length sequence))) - (with-subvector-accessor (sequence-ref sequence start end) - (if (not from-end) - (do ((i start (1+ i))) - ((>= i end) nil) - (when (test item (key (aref sequence i))) - (return (sequence-ref i)))) - (do ((i (1- end) (1- i))) - ((< i start) nil) - (when (test item (key (sequence-ref i))) - (return (sequence-ref i))))))) + (with-subvector-accessor (sequence-ref sequence) + (dotimes (i (length sequence)) + (when (eql item (sequence-ref i)) + (return item))))) (list - (if end - (do ((p (nthcdr start sequence) (cdr p)) - (i start (1+ i))) - ((or (>= i end) (endp p)) nil) - (when (test item (key (car p))) - (return (or (and from-end - (find item (cdr p) :from-end t :test test :key key :end (- end i 1))) - (car p))))) - (do ((p (nthcdr start sequence) (cdr p))) - ((endp p) nil) - (when (test item (key (car p))) - (return (or (and from-end (find item (cdr p) :from-end t :test test :key key)) - (car p))))))))))) + (dolist (x sequence) + (when (eql item x) + (return x)))))) + (t (item sequence &key from-end (test 'eql) (start 0) end (key 'identity)) + (with-funcallable (test) + (with-funcallable (key) + (sequence-dispatch sequence + (vector + (setf end (or end (length sequence))) + (with-subvector-accessor (sequence-ref sequence start end) + (if (not from-end) + (do ((i start (1+ i))) + ((>= i end) nil) + (when (test item (key (aref sequence i))) + (return (sequence-ref i)))) + (do ((i (1- end) (1- i))) + ((< i start) nil) + (when (test item (key (sequence-ref i))) + (return (sequence-ref i))))))) + (list + (if end + (do ((p (nthcdr start sequence) (cdr p)) + (i start (1+ i))) + ((or (>= i end) (endp p)) nil) + (when (test item (key (car p))) + (return (or (and from-end + (find item (cdr p) + :from-end t :test test + :key key :end (- end i 1))) + (car p))))) + (do ((p (nthcdr start sequence) (cdr p))) + ((endp p) nil) + (when (test item (key (car p))) + (return (or (and from-end (find item (cdr p) :from-end t :test test :key key)) + (car p))))))))))))) (defun find-if (predicate sequence &key from-end (start 0) end (key 'identity)) @@ -897,24 +912,42 @@ (incf n)))))))))) (defun count-if (predicate sequence &key (start 0) end (key 'identity) #+ignore from-end) - (with-funcallable (predicate) - (with-funcallable (key) - (sequence-dispatch sequence - (list - (if (not end) - (do ((n 0) - (p (nthcdr start sequence) (cdr p))) - ((endp p) n) - (when (predicate (key (car p))) - (incf n))) - (do ((n 0) - (i start (1+ i)) - (p (nthcdr start sequence) (cdr p))) - ((or (endp p) (>= i end)) n) - (when (predicate (key (car p))) - (incf n))))) - (vector - (error "vector count-if not implemented.")))))) + (numargs-case + (2 (predicate sequence) + (with-funcallable (predicate) + (sequence-dispatch sequence + (list + (let ((count 0)) + (dolist (x sequence) + (when (predicate x) + (incf count))) + count)) + (vector + (with-subvector-accessor (sequence-ref sequence) + (let ((count 0)) + (dotimes (i (length sequence)) + (when (predicate (sequence-ref i)) + (incf count))) + count)))))) + (t (predicate sequence &key (start 0) end (key 'identity) #+ignore from-end) + (with-funcallable (predicate) + (with-funcallable (key) + (sequence-dispatch sequence + (list + (if (not end) + (do ((n 0) + (p (nthcdr start sequence) (cdr p))) + ((endp p) n) + (when (predicate (key (car p))) + (incf n))) + (do ((n 0) + (i start (1+ i)) + (p (nthcdr start sequence) (cdr p))) + ((or (endp p) (>= i end)) n) + (when (predicate (key (car p))) + (incf n))))) + (vector + (error "vector count-if not implemented.")))))))) (macrolet ((every-some-body ()

1 0

[movitz-cvs] CVS update: movitz/special-operators-cl.lisp
by Frode Vatvedt Fjeld 30 Mar '04

30 Mar '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11520 Modified Files: special-operators-cl.lisp Log Message: For non-lexical go, add a bounds check for the calcuclated stack-pointer before assuming it. Date: Tue Mar 30 16:33:54 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.13 movitz/special-operators-cl.lisp:1.14 --- movitz/special-operators-cl.lisp:1.13 Tue Mar 30 14:36:15 2004 +++ movitz/special-operators-cl.lisp Tue Mar 30 16:33:54 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.13 2004/03/30 19:36:15 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.14 2004/03/30 21:33:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -704,6 +704,7 @@ `((:xorl :ebx :ebx) (:globally (:call (:edi (:edi-offset dynamic-locate-catch-tag)))) (:jnc '(:sub-program () (:int 108))) + (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax)) (:movl :eax :esp) (:movl (:esp) :ebp) (:movl (:ebp -4) :esi)

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