movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[movitz-cvs] CVS update: public_html/ChangeLog
by ffjeld＠common-lisp.net 21 Jul '05

21 Jul '05

Update of /project/movitz/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv32083 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Thu Jul 21 19:38:50 2005 Author: ffjeld Index: public_html/ChangeLog diff -u public_html/ChangeLog:1.7 public_html/ChangeLog:1.8 --- public_html/ChangeLog:1.7 Tue Jun 14 01:00:56 2005 +++ public_html/ChangeLog Thu Jul 21 19:38:50 2005 @@ -1,3 +1,11 @@ +2005-07-21 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> + + * Fixed the compiler to handle e.g. + (defun foo (x &optional y) + (lambda () y)) + which before would cause the compiler to fail with a message about + not being able to lend optionals. + 2005-06-14 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> * Added dynamic growing and rehashing of hash-tables.

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 21 Jul '05

21 Jul '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv31166 Modified Files: compiler.lisp Log Message: For 1req1opt functions (i.e. with arglist like (x &optional y)), make the compiler not die in pain from certain situations. That is, we can now deal with e.g. (defun foo (x &optional y) (lambda () y)) which before we couldn't/wouldn't. Date: Thu Jul 21 19:28:46 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.147 movitz/compiler.lisp:1.148 --- movitz/compiler.lisp:1.147 Thu Jun 16 22:55:42 2005 +++ movitz/compiler.lisp Thu Jul 21 19:28:46 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.147 2005/06/16 20:55:42 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.148 2005/07/21 17:28:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -848,28 +848,35 @@ req-location opt-location))) (cond ((not optp-location) - ()) - ((= optp-location (1+ stack-setup-pre)) - (incf stack-setup-pre 1) - `((:pushl :edx))) + (make-stack-setup-code (- stack-frame-size stack-setup-pre))) + ((and (integerp optp-location) + (= optp-location (1+ stack-setup-pre))) + (append `((:pushl :edx)) + (make-stack-setup-code (- stack-frame-size stack-setup-pre 1)))) + ((integerp optp-location) + (append (make-stack-setup-code (- stack-frame-size stack-setup-pre)) + `((:movl :edx (:ebp ,(stack-frame-offset optp-location)))))) (t (error "Can't deal with optional-p at ~S, after (~S ~S)." optp-location req-location opt-location))) - (make-stack-setup-code (- stack-frame-size stack-setup-pre)) - (when (binding-lended-p req-binding) - (let ((lended-cons-position (getf (binding-lending req-binding) - :stack-cons-location))) - (etypecase req-location - (integer - `((:movl (:ebp ,(stack-frame-offset req-location)) :edx) - (:movl :edi (:ebp ,(stack-frame-offset lended-cons-position))) ; cdr - (:movl :edx (:ebp ,(stack-frame-offset (1+ lended-cons-position)))) ; car - (:leal (:ebp 1 ,(stack-frame-offset (1+ lended-cons-position))) - :edx) - (:movl :edx (:ebp ,(stack-frame-offset req-location)))))))) - (when (binding-lended-p opt-binding) - (error "Can't deal with lending optional right now.")) - (when (and optp-binding (binding-lended-p optp-binding)) - (error "Can't deal with lending optionalp right now.")) + (flet ((make-lending (location lended-cons-position) + (etypecase req-location + (integer + `((:movl (:ebp ,(stack-frame-offset location)) :edx) + (:movl :edi (:ebp ,(stack-frame-offset lended-cons-position))) ; cdr + (:movl :edx (:ebp ,(stack-frame-offset (1+ lended-cons-position)))) ; car + (:leal (:ebp 1 ,(stack-frame-offset (1+ lended-cons-position))) + :edx) + (:movl :edx (:ebp ,(stack-frame-offset location)))))))) + (append + (when (binding-lended-p req-binding) + (make-lending req-location (getf (binding-lending req-binding) + :stack-cons-location))) + (when (binding-lended-p opt-binding) + (make-lending opt-location (getf (binding-lending opt-binding) + :stack-cons-location))) + (when (and optp-binding (binding-lended-p optp-binding)) + (make-lending optp-location (getf (binding-lending optp-binding) + :stack-cons-location))))) resolved-code (make-compiled-function-postlude funobj function-env use-stack-frame-p)))))

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 16 Jun '05

16 Jun '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv15543 Modified Files: compiler.lisp Log Message: *** empty log message *** Date: Thu Jun 16 22:55:42 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.146 movitz/compiler.lisp:1.147 --- movitz/compiler.lisp:1.146 Thu Jun 16 10:46:04 2005 +++ movitz/compiler.lisp Thu Jun 16 22:55:42 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.146 2005/06/16 08:46:04 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.147 2005/06/16 20:55:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5564,14 +5564,6 @@ (types (list* (type-specifier-primary (compiler-values-getf all0 :type)) (type-specifier-primary (compiler-values-getf all1 :type)) (nreverse arguments-types)))) - #+ignore - (when (and (= 4 (length argument-forms)) - (string= "WINDOW-TREE" (first argument-forms))) - (warn "final0: ~s, f1: ~S, typ: ~S, asep: ~S, aall: ~S" - final0 final1 - types - arguments-self-evaluating-p - arguments-are-load-lexicals-p)) (cond ((or arguments-self-evaluating-p (and (typep final0 'lexical-binding) @@ -5585,15 +5577,6 @@ ((and arguments-are-load-lexicals-p (typep final0 '(or lexical-binding movitz-object)) (typep final1 '(or lexical-binding movitz-object))) - (values (append arguments-code code01) - (+ -2 (length argument-forms)) - nil - types - arguments-functional-p)) - ((and (typep final0 '(or lexical-binding movitz-object)) - (typep final1 '(or lexical-binding movitz-object)) - (not (modifies-member final0 arguments-modifies)) - (not (modifies-member final1 arguments-modifies))) (values (append arguments-code code01) (+ -2 (length argument-forms)) nil

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/hash-tables.lisp
by ffjeld＠common-lisp.net 16 Jun '05

16 Jun '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv8346 Modified Files: hash-tables.lisp Log Message: Various tweaks to several hash functions. Date: Thu Jun 16 12:00:52 2005 Author: ffjeld Index: movitz/losp/muerte/hash-tables.lisp diff -u movitz/losp/muerte/hash-tables.lisp:1.7 movitz/losp/muerte/hash-tables.lisp:1.8 --- movitz/losp/muerte/hash-tables.lisp:1.7 Tue Jun 14 01:00:25 2005 +++ movitz/losp/muerte/hash-tables.lisp Thu Jun 16 12:00:51 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Feb 19 19:09:05 2001 ;;;; -;;;; $Id: hash-tables.lisp,v 1.7 2005/06/13 23:00:25 ffjeld Exp $ +;;;; $Id: hash-tables.lisp,v 1.8 2005/06/16 10:00:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -49,20 +49,11 @@ :sxhash sxhash :count 0))) -;;;(defun hash-table-count (hash-table) -;;; (do* ((bucket (hash-table-bucket hash-table)) -;;; (length (length bucket)) -;;; (count 0) -;;; (i 0 (+ i 2))) -;;; ((>= i length) count) -;;; (unless (eq (svref bucket i) '--no-hash-key--) -;;; (incf count)))) - (defun hash-table-iterator (bucket index) (when index (do ((length (array-dimension bucket 0))) ((>= index length) nil) - (unless (eq (svref bucket index) '--no-hash-key--) + (unless (eq (svref%unsafe bucket index) '--no-hash-key--) (return (+ index 2))) (incf index 2)))) @@ -75,8 +66,8 @@ `(when (setq ,',bucket-index-var (hash-table-iterator ,',bucket-var ,',bucket-index-var)) (values t - (svref ,',bucket-var (- ,',bucket-index-var 2)) - (svref ,',bucket-var (- ,',bucket-index-var 1)))))) + (svref%unsafe ,',bucket-var (- ,',bucket-index-var 2)) + (svref%unsafe ,',bucket-var (- ,',bucket-index-var 1)))))) ,@declarations-and-body)))) (defun sxhash-subvector (vector start end &optional (limit 8)) @@ -114,7 +105,8 @@ (typecase object (null 0) (symbol - (movitz-accessor-u16 object movitz-symbol hash-key)) + (memref object (movitz-type-slot-offset 'movitz-symbol 'hash-key) + :type :unsigned-byte16)) (t (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) object) (:andl #.(cl:logxor #xffffffff movitz::+movitz-fixnum-zmask+) :eax))))) @@ -128,6 +120,7 @@ (bucket-length (length bucket)) (start-i2 (rem (ash (funcall (hash-table-sxhash hash-table) key) 1) bucket-length)) (i2 start-i2)) + (declare (type index i2)) (do () (nil) (let ((k (svref%unsafe bucket i2))) (cond @@ -179,10 +172,8 @@ (do* ((test (hash-table-test hash-table)) (bucket (hash-table-bucket hash-table)) (bucket-length (length bucket)) - (index2 (rem (ash (funcall (hash-table-sxhash hash-table) key) 1) bucket-length)) - (c 2 (+ c 2))) - ((>= c bucket-length) - (error "Hash-table bucket is full, needs rehashing, which isn't implemented.")) + (index2 (rem (ash (funcall (hash-table-sxhash hash-table) key) 1) bucket-length))) + (nil) (let ((k (svref%unsafe bucket index2))) (cond ((eq k '--no-hash-key--) @@ -262,15 +253,17 @@ (do* ((bucket (hash-table-bucket hash-table)) (bucket-length (length bucket)) (i 0 (+ i 2))) - ((>= i bucket-length) hash-table) - (setf (svref bucket i) '--no-hash-key--))) + ((>= i bucket-length)) + (setf (svref bucket i) '--no-hash-key--)) + hash-table) (defun maphash (function hash-table) - (with-hash-table-iterator (get-next-entry hash-table) - (do () (nil) - (multiple-value-bind (entry-p key value) - (get-next-entry) - (if (not entry-p) - (return nil) - (funcall function key value)))))) + (with-funcallable (map function) + (with-hash-table-iterator (get-next-entry hash-table) + (do () (nil) + (multiple-value-bind (entry-p key value) + (get-next-entry) + (if (not entry-p) + (return nil) + (map key value)))))))

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 16 Jun '05

16 Jun '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv3756 Modified Files: compiler.lisp Log Message: Be more clever about when function-arguments can be re-ordered. We were overly optimistic before, which could result in subtle bugs. Date: Thu Jun 16 10:46:04 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.145 movitz/compiler.lisp:1.146 --- movitz/compiler.lisp:1.145 Wed Jun 15 23:48:19 2005 +++ movitz/compiler.lisp Thu Jun 16 10:46:04 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.145 2005/06/15 21:48:19 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.146 2005/06/16 08:46:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5549,10 +5549,10 @@ (setf arguments-self-evaluating-p nil) (assert (eq :load-lexical (caar code)) () "comp-lex-var produced for ~S~% ~S" form code) - (pushnew (second code) arguments-lexical-variables)) + (pushnew (cadar code) arguments-lexical-variables)) (t (setf arguments-self-evaluating-p nil arguments-are-load-lexicals-p nil))) - code)))) + code)))) (multiple-value-bind (code01 functionalp01 modifies01 all0 all1) (make-compiled-two-forms-into-registers (first argument-forms) :eax (second argument-forms) :ebx @@ -5564,6 +5564,14 @@ (types (list* (type-specifier-primary (compiler-values-getf all0 :type)) (type-specifier-primary (compiler-values-getf all1 :type)) (nreverse arguments-types)))) + #+ignore + (when (and (= 4 (length argument-forms)) + (string= "WINDOW-TREE" (first argument-forms))) + (warn "final0: ~s, f1: ~S, typ: ~S, asep: ~S, aall: ~S" + final0 final1 + types + arguments-self-evaluating-p + arguments-are-load-lexicals-p)) (cond ((or arguments-self-evaluating-p (and (typep final0 'lexical-binding) @@ -5592,9 +5600,9 @@ types arguments-functional-p)) ((and arguments-are-load-lexicals-p - (not (operators-present-in-code-p code01 - '(:store-lexical) - arguments-lexical-variables))) + (not (some (lambda (arg-binding) + (code-uses-binding-p code01 arg-binding :store t :load nil)) + arguments-lexical-variables))) (values (append arguments-code code01) (+ -2 (length argument-forms)) nil

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 15 Jun '05

15 Jun '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv28097 Modified Files: compiler.lisp Log Message: Don't use ECX as temporary storage for lisp-vals! Date: Wed Jun 15 23:48:19 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.144 movitz/compiler.lisp:1.145 --- movitz/compiler.lisp:1.144 Tue May 24 08:32:27 2005 +++ movitz/compiler.lisp Wed Jun 15 23:48:19 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.144 2005/05/24 06:32:27 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.145 2005/06/15 21:48:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3606,8 +3606,8 @@ (dest-location (new-binding-location destination frame-map :default nil))) (cond ((not dest-location) ; unknown, e.g. a borrowed-binding. - (append (install-for-single-value binding binding-location :ecx nil) - (make-store-lexical result-mode :ecx nil funobj frame-map))) + (append (install-for-single-value binding binding-location :edx nil) + (make-store-lexical result-mode :edx nil funobj frame-map))) ((equal binding-location dest-location) nil) ((member binding-location '(:eax :ebx :ecx :edx)) @@ -3655,6 +3655,8 @@ (if (not shared-reference-p) (let ((tmp-reg (chose-free-register protect-registers) #+ignore(if (eq source :eax) :ebx :eax))) + (when (eq :ecx source) + (break "loading a word from ECX?")) `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot))) ,tmp-reg) (:movl ,source (-1 ,tmp-reg))))

1 0

[movitz-cvs] CVS update: public_html/ChangeLog
by ffjeld＠common-lisp.net 13 Jun '05

13 Jun '05

Update of /project/movitz/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv18347 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Tue Jun 14 01:00:56 2005 Author: ffjeld Index: public_html/ChangeLog diff -u public_html/ChangeLog:1.6 public_html/ChangeLog:1.7 --- public_html/ChangeLog:1.6 Sat Jun 11 01:17:17 2005 +++ public_html/ChangeLog Tue Jun 14 01:00:56 2005 @@ -1,3 +1,7 @@ +2005-06-14 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> + + * Added dynamic growing and rehashing of hash-tables. + 2005-06-11 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> * Started to add support for adjustable and displaced vectors.

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/hash-tables.lisp
by ffjeld＠common-lisp.net 13 Jun '05

13 Jun '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18056 Modified Files: hash-tables.lisp Log Message: Improved hash-tables somewhat: dynamically grow and rehash. Also, decreased the hash-table-size of dumped hash-tables, which apparently decreased the image-size by 10%. Date: Tue Jun 14 01:00:26 2005 Author: ffjeld Index: movitz/losp/muerte/hash-tables.lisp diff -u movitz/losp/muerte/hash-tables.lisp:1.6 movitz/losp/muerte/hash-tables.lisp:1.7 --- movitz/losp/muerte/hash-tables.lisp:1.6 Sun May 8 03:18:29 2005 +++ movitz/losp/muerte/hash-tables.lisp Tue Jun 14 01:00:25 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Feb 19 19:09:05 2001 ;;;; -;;;; $Id: hash-tables.lisp,v 1.6 2005/05/08 01:18:29 ffjeld Exp $ +;;;; $Id: hash-tables.lisp,v 1.7 2005/06/13 23:00:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -31,7 +31,8 @@ (defstruct (hash-table (:constructor make-hash-table-object)) test bucket - sxhash) + sxhash + count) (defun make-hash-table (&key (test 'eql) (size 47) rehash-size rehash-threshold) (declare (ignore rehash-size rehash-threshold)) @@ -45,16 +46,17 @@ (make-hash-table-object :test test :bucket (make-array (* 2 size) :initial-element '--no-hash-key--) - :sxhash sxhash))) + :sxhash sxhash + :count 0))) -(defun hash-table-count (hash-table) - (do* ((bucket (hash-table-bucket hash-table)) - (length (length bucket)) - (count 0) - (i 0 (+ i 2))) - ((>= i length) count) - (unless (eq (svref bucket i) '--no-hash-key--) - (incf count)))) +;;;(defun hash-table-count (hash-table) +;;; (do* ((bucket (hash-table-bucket hash-table)) +;;; (length (length bucket)) +;;; (count 0) +;;; (i 0 (+ i 2))) +;;; ((>= i length) count) +;;; (unless (eq (svref bucket i) '--no-hash-key--) +;;; (incf count)))) (defun hash-table-iterator (bucket index) (when index @@ -182,12 +184,30 @@ ((>= c bucket-length) (error "Hash-table bucket is full, needs rehashing, which isn't implemented.")) (let ((k (svref%unsafe bucket index2))) - (when (or (eq k '--no-hash-key--) - (funcall test k key)) + (cond + ((eq k '--no-hash-key--) + (let ((new-count (1+ (hash-table-count hash-table)))) + (cond + ((>= (truncate (* new-count 8) 3) bucket-length) + ;; Rehash.. + (setf (hash-table-bucket hash-table) (make-array (* 2 (+ bucket-length 7)) + :initial-element '--no-hash-key--) + (hash-table-count hash-table) 0) + (do ((i 0 (+ i 2))) + ((>= i bucket-length)) + (let ((old-key (svref%unsafe bucket i))) + (unless (eq old-key '--no-hash-key--) + (setf (gethash old-key hash-table) + (svref%unsafe bucket (1+ i)))))) + (return (setf (gethash key hash-table) value))) + (t (return (setf (hash-table-count hash-table) new-count + (svref%unsafe bucket index2) key + (svref%unsafe bucket (1+ index2)) value)))))) + ((funcall test k key) (return (setf (svref%unsafe bucket index2) key - (svref%unsafe bucket (1+ index2)) value)))) - (when (>= (incf index2 2) bucket-length) - (setf index2 0)))) + (svref%unsafe bucket (1+ index2)) value))) + ((>= (incf index2 2) bucket-length) + (setf index2 0)))))) (defun gethash-string (key-string start end hash-table &optional default (key 'identity)) (let ((bucket (hash-table-bucket hash-table))) @@ -223,6 +243,7 @@ (when (or (eq x '--no-hash-key--) (funcall (hash-table-test hash-table) x key)) (setf (svref bucket index2) '--no-hash-key--) + (decf (hash-table-count hash-table)) ;; Now we must rehash any entries that might have been ;; displaced by the one we have now removed. (do ((i (rem (+ index2 2) bucket-length) @@ -237,6 +258,7 @@ (return t))))) (defun clrhash (hash-table) + (setf (hash-table-count hash-table) 0) (do* ((bucket (hash-table-bucket hash-table)) (bucket-length (length bucket)) (i 0 (+ i 2)))

1 0

[movitz-cvs] CVS update: movitz/storage-types.lisp
by ffjeld＠common-lisp.net 13 Jun '05

13 Jun '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv17871 Modified Files: storage-types.lisp Log Message: Improved hash-tables somewhat: dynamically grow and rehash. Also, decreased the hash-table-size of dumped hash-tables, which apparently decreased the image-size by 10%. Date: Tue Jun 14 01:00:19 2005 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.53 movitz/storage-types.lisp:1.54 --- movitz/storage-types.lisp:1.53 Fri Jun 10 00:18:55 2005 +++ movitz/storage-types.lisp Tue Jun 14 01:00:17 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.53 2005/06/09 22:18:55 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.54 2005/06/13 23:00:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1021,7 +1021,8 @@ (defun make-movitz-hash-table (lisp-hash) (let* ((undef (movitz-read +undefined-hash-key+)) - (hash-size (* 2 (truncate (+ 25 (hash-table-count lisp-hash)) 1/3))) + (hash-count (hash-table-count lisp-hash)) + (hash-size (logand -2 (truncate (* 2 4/3 (+ 7 hash-count))))) (bucket-data (make-array hash-size :initial-element undef))) (multiple-value-bind (hash-test hash-sxhash) (ecase (hash-table-test lisp-hash) @@ -1044,18 +1045,20 @@ (let* ((bucket (make-movitz-vector hash-size :initial-contents bucket-data)) (lh (make-instance 'movitz-struct :class (muerte::movitz-find-class 'muerte::hash-table) - :length 3 + :length 4 :slot-values (list hash-test ; test-function bucket - hash-sxhash)))) + hash-sxhash + hash-count)))) lh)))) (defmethod update-movitz-object ((movitz-hash movitz-struct) (lisp-hash hash-table)) "Keep <movitz-hash> in sync with <lisp-hash>." - (assert (= 3 (length (movitz-struct-slot-values movitz-hash)))) + (assert (= 4 (length (movitz-struct-slot-values movitz-hash)))) (let* ((undef (movitz-read +undefined-hash-key+)) (old-bucket (second (movitz-struct-slot-values movitz-hash))) - (hash-size (* 2 (truncate (+ 25 (hash-table-count lisp-hash)) 1/3))) + (hash-count (hash-table-count lisp-hash)) + (hash-size (logand -2 (truncate (* 2 4/3 (+ 7 hash-count))))) (bucket-data (or (and old-bucket (= (length (movitz-vector-symbolic-data old-bucket)) hash-size) @@ -1082,7 +1085,8 @@ (svref bucket-data (1+ pos)) movitz-value))) (setf (first (movitz-struct-slot-values movitz-hash)) hash-test (second (movitz-struct-slot-values movitz-hash)) (movitz-read bucket-data) - (third (movitz-struct-slot-values movitz-hash)) hash-sxhash) + (third (movitz-struct-slot-values movitz-hash)) hash-sxhash + (fourth (movitz-struct-slot-values movitz-hash)) hash-count) movitz-hash))) ;;;

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/lists.lisp
by ffjeld＠common-lisp.net 12 Jun '05

12 Jun '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19223 Modified Files: lists.lisp Log Message: Wrote copy-tree and changed tree-equal. Date: Sun Jun 12 23:27:08 2005 Author: ffjeld Index: movitz/losp/muerte/lists.lisp diff -u movitz/losp/muerte/lists.lisp:1.10 movitz/losp/muerte/lists.lisp:1.11 --- movitz/losp/muerte/lists.lisp:1.10 Fri Nov 19 21:13:44 2004 +++ movitz/losp/muerte/lists.lisp Sun Jun 12 23:27:07 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 20012000, 2002-2004, +;;;; Copyright (C) 20012000, 2002-2005, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: lists.lisp @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.10 2004/11/19 20:13:44 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.11 2005/06/12 21:27:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -140,17 +140,6 @@ (defun (setf nth) (value n list) (setf (car (nthcdr n list)) value)) - -(defun tree-equal (tree-1 tree-2 &key (test 'equal)) - (cond - ((atom tree-1) - (and (atom tree-2) - (funcall test tree-1 tree-2))) - ((atom tree-2) - nil) - (t (and (tree-equal (car tree-1) (car tree-2) :test test) - (tree-equal (cdr tree-1) (cdr tree-2) :test test))))) - (defun nconc (&rest lists) (declare (dynamic-extent lists))

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