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

[movitz-cvs] CVS update: movitz/losp/muerte/format.lisp
by Frode Vatvedt Fjeld 30 Jul '04

30 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26913 Modified Files: format.lisp Log Message: Tune-up of format-float: Round off the last digit properly. Date: Fri Jul 30 15:15:23 2004 Author: ffjeld Index: movitz/losp/muerte/format.lisp diff -u movitz/losp/muerte/format.lisp:1.6 movitz/losp/muerte/format.lisp:1.7 --- movitz/losp/muerte/format.lisp:1.6 Thu Jul 29 09:21:39 2004 +++ movitz/losp/muerte/format.lisp Fri Jul 30 15:15:23 2004 @@ -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.6 2004/07/29 16:21:39 ffjeld Exp $ +;;;; $Id: format.lisp,v 1.7 2004/07/30 22:15:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -59,21 +59,27 @@ (*print-readably* nil)) (write x)))) -(defun format-float (x &optional at-sign-p colon-p w d k overflowchar padchar) - (declare (ignore w k overflowchar padchar at-sign-p colon-p)) - (multiple-value-bind (integer-part decimal-part) - (truncate x) - (write-integer integer-part *standard-output* 10 t) - (do ((remainder decimal-part) - (i 0 (1+ i))) - ((if (not d) - (or (and (plusp i) (zerop decimal-part)) - (>= i 16)) - (= i d))) - (multiple-value-bind (next-digit next-remainder) - (truncate (* 10 remainder)) - (setf remainder next-remainder) - (write-integer next-digit *standard-output* 10 nil))))) +(defun format-float (x &optional at-sign-p colon-p w d (k 0) overflowchar padchar) + (declare (ignore w overflowchar padchar at-sign-p colon-p)) + (if (eql 0 d) + (write-integer (round x) *standard-output* 10 nil) + (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))) + (multiple-value-bind (next-digit next-remainder) + (if (= i last-i) + (round (* 10 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 update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 30 Jul '04

30 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6080 Modified Files: integers.lisp Log Message: Improved ratio support in +, -, truncate, and compare. Date: Fri Jul 30 15:10:59 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.88 movitz/losp/muerte/integers.lisp:1.89 --- movitz/losp/muerte/integers.lisp:1.88 Fri Jul 30 14:06:27 2004 +++ movitz/losp/muerte/integers.lisp Fri Jul 30 15:10:59 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.88 2004/07/30 21:06:27 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.89 2004/07/30 22:10:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -690,14 +690,10 @@ (- x (- y))) (((integer * -1) (integer * -1)) (%negatef (+ (- x) (- y)) x y)) - ((ratio t) - (make-rational (+ (* (ratio-numerator x) (denominator y)) - (* (numerator y) (ratio-denominator x))) - (* (ratio-denominator x) (denominator y)))) - ((integer ratio) - (make-rational (+ (* x (denominator y)) - (* (ratio-numerator y) x)) - (denominator y))) + ((rational rational) + (/ (+ (* (numerator x) (denominator y)) + (* (numerator y) (denominator x))) + (* (denominator x) (denominator y)))) ))) (do-it))) (t (&rest terms) @@ -728,7 +724,10 @@ (:testb 7 :cl) (:jnz '(:sub-program (not-a-number) (:compile-form (:result-mode :ignore) - (error 'type-error :expected-type 'number :datum x)))) + (if (ratio-p x) + (make-rational (- (ratio-numerator x)) + (ratio-denominator x)) + (error 'type-error :expected-type 'number :datum x))))) (:movl (:eax ,movitz:+other-type-offset+) :ecx) (:cmpb ,(movitz:tag :bignum) :cl) (:jne 'not-a-number) @@ -834,6 +833,10 @@ (%negatef (+ (- minuend) subtrahend) minuend subtrahend)) (((integer * -1) (integer * -1)) (+ minuend (- subtrahend))) + ((rational rational) + (/ (- (* (numerator minuend) (denominator subtrahend)) + (* (numerator subtrahend) (denominator minuend))) + (* (denominator minuend) (denominator subtrahend)))) ))) (do-it))) (t (minuend &rest subtrahends) @@ -1218,7 +1221,12 @@ (t (number divisor) (number-double-dispatch (number divisor) ((t (eql 1)) - (values number 0)) + (if (not (ratio-p number)) + (values number 0) + (multiple-value-bind (q r) + (truncate (ratio-numerator number) + (ratio-denominator number)) + (values q (make-rational r (ratio-denominator number)))))) ((fixnum fixnum) (with-inline-assembly (:returns :multiple-values) (:compile-form (:result-mode :eax) number)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/ratios.lisp
by Frode Vatvedt Fjeld 30 Jul '04

30 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7552 Modified Files: ratios.lisp Log Message: Rational is the direct superclass of ratio, not number. Date: Fri Jul 30 15:04:17 2004 Author: ffjeld Index: movitz/losp/muerte/ratios.lisp diff -u movitz/losp/muerte/ratios.lisp:1.3 movitz/losp/muerte/ratios.lisp:1.4 --- movitz/losp/muerte/ratios.lisp:1.3 Fri Jul 30 14:06:31 2004 +++ movitz/losp/muerte/ratios.lisp Fri Jul 30 15:04:17 2004 @@ -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.3 2004/07/30 21:06:31 ffjeld Exp $ +;;;; $Id: ratios.lisp,v 1.4 2004/07/30 22:04:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,7 +22,7 @@ (in-package muerte) (defstruct (ratio (:constructor make-ratio (numerator denominator)) - (:superclass number)) + (:superclass rational)) numerator denominator) (defun make-rational (numerator denominator)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/ratios.lisp
by Frode Vatvedt Fjeld 30 Jul '04

30 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4276 Modified Files: ratios.lisp Log Message: Improved support for ratios in compare (i.e. <, <=, >, etc). Date: Fri Jul 30 14:06:31 2004 Author: ffjeld Index: movitz/losp/muerte/ratios.lisp diff -u movitz/losp/muerte/ratios.lisp:1.2 movitz/losp/muerte/ratios.lisp:1.3 --- movitz/losp/muerte/ratios.lisp:1.2 Thu Jul 29 09:20:43 2004 +++ movitz/losp/muerte/ratios.lisp Fri Jul 30 14:06:31 2004 @@ -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.2 2004/07/29 16:20:43 ffjeld Exp $ +;;;; $Id: ratios.lisp,v 1.3 2004/07/30 21:06:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -26,7 +26,6 @@ numerator denominator) (defun make-rational (numerator denominator) - (assert (not (eq 0 denominator))) (check-type numerator integer) (check-type denominator integer) (cond

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 30 Jul '04

30 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4062 Modified Files: integers.lisp Log Message: Improved support for ratios in compare (i.e. <, <=, >, etc). Date: Fri Jul 30 14:06:27 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.87 movitz/losp/muerte/integers.lisp:1.88 --- movitz/losp/muerte/integers.lisp:1.87 Tue Jul 27 15:05:14 2004 +++ movitz/losp/muerte/integers.lisp Fri Jul 30 14:06:27 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.87 2004/07/27 22:05:14 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.88 2004/07/30 21:06:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -47,11 +47,12 @@ ;; Check that both numbers are bignums, and compare them. (:leal (:eax ,(- (movitz:tag :other))) :ecx) (:testb 7 :cl) - (:jnz '(:sub-program (n1-not-bignum) - (:int 64))) + (:jnz '(:sub-program (go-complicated) + (:globally (:movl (:edi (:edi-offset complicated-compare)) :esi)) + (:jmp (:esi (:offset movitz-funobj code-vector%2op))))) (:movl (:eax ,movitz:+other-type-offset+) :ecx) (:cmpb ,(movitz:tag :bignum) :cl) - (:jne 'n1-not-bignum) + (:jne 'go-complicated) (:cmpl :eax :ebx) ; If they are EQ, they are certainly = (:je '(:sub-program (n1-and-n2-are-eq) @@ -59,12 +60,10 @@ (:leal (:ebx ,(- (movitz:tag :other))) :ecx) (:testb 7 :cl) - (:jnz '(:sub-program (n2-not-bignum) - (:movl :ebx :eax) - (:int 64))) + (:jnz 'go-complicated) (:movl (:ebx ,movitz:+other-type-offset+) :ecx) (:cmpb ,(movitz:tag :bignum) :cl) - (:jne 'n2-not-bignum) + (:jne 'go-complicated) (:cmpb :ch (:eax (:offset movitz-bignum sign))) (:jne '(:sub-program (different-signs) @@ -184,9 +183,9 @@ n2-not-fixnum (:leal (:ebx ,(- (movitz:tag :other))) :ecx) (:testb 7 :cl) - (:jnz '(:sub-program (not-integer) - (:movl :ebx :eax) - (:int 64))) + (:jnz '(:sub-program (go-complicated) + (:globally (:movl (:edi (:edi-offset complicated-compare)) :esi)) + (:jmp (:esi (:offset movitz-funobj code-vector%2op))))) (:movl (:ebx ,movitz:+other-type-offset+) :ecx) (:cmpw ,(movitz:tag :bignum 0) :cx) (:jne 'not-plusbignum) @@ -195,7 +194,7 @@ (:ret) not-plusbignum (:cmpw ,(movitz:tag :bignum #xff) :cx) - (:jne 'not-integer) + (:jne 'go-complicated) ;; compare ebx with something bigger (:cmpl #x-10000000 :edi) (:ret)))) @@ -211,8 +210,9 @@ not-fixnum (:leal (:eax #.(cl:- (movitz:tag :other))) :ecx) (:testb 7 :cl) - (:jnz '(:sub-program (not-integer) - (:int 64))) + (:jnz '(:sub-program (go-complicated) + (:globally (:movl (:edi (:edi-offset complicated-compare)) :esi)) + (:jmp (:esi (:offset movitz-funobj code-vector%2op))))) (:movl (:eax #.movitz:+other-type-offset+) :ecx) (:cmpw #.(movitz:tag :bignum 0) :cx) (:jne 'not-plusbignum) @@ -221,10 +221,19 @@ (:ret) not-plusbignum (:cmpw #.(movitz:tag :bignum #xff) :cx) - (:jne 'not-integer) + (:jne 'go-complicated) ;; compare ebx with something bigger (:cmpl #x10000000 :edi) (:ret))) + +(defun complicated-compare (x y) + (let ((ix (* (numerator x) (denominator y))) + (iy (* (numerator y) (denominator x)))) + (with-inline-assembly (:returns :multiple-values) + (:compile-two-forms (:eax :ebx) ix iy) + (:call-global-pf fast-compare-two-reals) + (:movl 1 :ecx) ; The real result is in EFLAGS. + (:movl :edi :eax)))) ;;;

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by Frode Vatvedt Fjeld 30 Jul '04

30 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv3906 Modified Files: image.lisp Log Message: Improved support for ratios in compare (i.e. <, <=, >, etc). Date: Fri Jul 30 14:06:22 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.57 movitz/image.lisp:1.58 --- movitz/image.lisp:1.57 Thu Jul 29 09:18:47 2004 +++ movitz/image.lisp Fri Jul 30 14:06:22 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.57 2004/07/29 16:18:47 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.58 2004/07/30 21:06:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -294,6 +294,11 @@ :map-binary-write 'movitz-intern :map-binary-read-delayed 'movitz-word) (complicated-class-of + :binary-type word + :binary-tag :global-function + :map-binary-read-delayed 'movitz-word + :map-binary-write 'movitz-intern) + (complicated-compare :binary-type word :binary-tag :global-function :map-binary-read-delayed 'movitz-word

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/format.lisp
by Frode Vatvedt Fjeld 29 Jul '04

29 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv22690 Modified Files: format.lisp Log Message: Added an imbecile format-float, for ~F. Date: Thu Jul 29 09:21:39 2004 Author: ffjeld Index: movitz/losp/muerte/format.lisp diff -u movitz/losp/muerte/format.lisp:1.5 movitz/losp/muerte/format.lisp:1.6 --- movitz/losp/muerte/format.lisp:1.5 Thu May 20 10:47:24 2004 +++ movitz/losp/muerte/format.lisp Thu Jul 29 09:21:39 2004 @@ -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.5 2004/05/20 17:47:24 ffjeld Exp $ +;;;; $Id: format.lisp,v 1.6 2004/07/29 16:21:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -59,6 +59,22 @@ (*print-readably* nil)) (write x)))) +(defun format-float (x &optional at-sign-p colon-p w d k overflowchar padchar) + (declare (ignore w k overflowchar padchar at-sign-p colon-p)) + (multiple-value-bind (integer-part decimal-part) + (truncate x) + (write-integer integer-part *standard-output* 10 t) + (do ((remainder decimal-part) + (i 0 (1+ i))) + ((if (not d) + (or (and (plusp i) (zerop decimal-part)) + (>= i 16)) + (= i d))) + (multiple-value-bind (next-digit next-remainder) + (truncate (* 10 remainder)) + (setf remainder next-remainder) + (write-integer next-digit *standard-output* 10 nil))))) + (defun find-directive (string i directive &optional recursive-skip-start (recursive-skip-end directive)) "Return position of <directive> in <string>, starting search at <i>. Also return @@ -142,6 +158,7 @@ (nreverse prefix-parameters))) (#\X (format-integer (pop args) 16 at-sign-p colon-p (nreverse prefix-parameters))) + (#\F (apply 'format-float (pop args) at-sign-p colon-p (nreverse prefix-parameters))) (#\C (if colon-p (let ((c (pop args))) (write-string (or (char-name c) c))) @@ -292,3 +309,4 @@ end-loop) (values i args))) +

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/ratios.lisp
by Frode Vatvedt Fjeld 29 Jul '04

29 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17760 Modified Files: ratios.lisp Log Message: Add a defconstant pi, for the fun of it. Date: Thu Jul 29 09:20:43 2004 Author: ffjeld Index: movitz/losp/muerte/ratios.lisp diff -u movitz/losp/muerte/ratios.lisp:1.1 movitz/losp/muerte/ratios.lisp:1.2 --- movitz/losp/muerte/ratios.lisp:1.1 Tue Jul 27 06:54:12 2004 +++ movitz/losp/muerte/ratios.lisp Thu Jul 29 09:20:43 2004 @@ -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.1 2004/07/27 13:54:12 ffjeld Exp $ +;;;; $Id: ratios.lisp,v 1.2 2004/07/29 16:20:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -51,3 +51,5 @@ (etypecase x (integer 1) (ratio (ratio-denominator x)))) + +(defconstant pi #xea7632a/4aa1a8b)

1 0

[movitz-cvs] CVS update: movitz/losp/lib/readline.lisp
by Frode Vatvedt Fjeld 29 Jul '04

29 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv12977 Modified Files: readline.lisp Log Message: Minor fix: dont assume the screen is 25 characters high. Date: Thu Jul 29 09:20:18 2004 Author: ffjeld Index: movitz/losp/lib/readline.lisp diff -u movitz/losp/lib/readline.lisp:1.4 movitz/losp/lib/readline.lisp:1.5 --- movitz/losp/lib/readline.lisp:1.4 Fri Feb 13 14:11:19 2004 +++ movitz/losp/lib/readline.lisp Thu Jul 29 09:20:18 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 2 13:58:58 2001 ;;;; -;;;; $Id: readline.lisp,v 1.4 2004/02/13 22:11:19 ffjeld Exp $ +;;;; $Id: readline.lisp,v 1.5 2004/07/29 16:20:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -135,7 +135,7 @@ when (member key terminator-keys) do (when displayed-completions-p (do ((y (1+ (cursor-y console)) (1+ y))) - ((>= y 25)) + ((>= y (console-height console))) (clear-line console 0 y))) and return key do (case key

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by Frode Vatvedt Fjeld 29 Jul '04

29 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv5345 Modified Files: image.lisp Log Message: Added support for movitz-read'ing ratios. Date: Thu Jul 29 09:18:47 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.56 movitz/image.lisp:1.57 --- movitz/image.lisp:1.56 Wed Jul 28 18:59:13 2004 +++ movitz/image.lisp Thu Jul 29 09:18:47 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.56 2004/07/29 01:59:13 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.57 2004/07/29 16:18:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1426,61 +1426,75 @@ (declare (special *movitz-reader-clean-map*)) ,@body)) -(defun movitz-read (expr) +(defun movitz-read (expr &optional re-read) "Map native lisp data to movitz-objects. Makes sure that when two EXPR are EQ, ~@ the Movitz objects are also EQ, under the same image." (declare (optimize (debug 3) (speed 0))) (with-movitz-read-context () (when (typep expr 'movitz-object) (return-from movitz-read expr)) - (or - (let ((old-object (image-lisp-to-movitz-object *image* expr))) - (when (and old-object (not (gethash old-object *movitz-reader-clean-map*))) - (update-movitz-object old-object expr) - (setf (gethash old-object *movitz-reader-clean-map*) t)) - old-object) - (setf (image-lisp-to-movitz-object *image* expr) - (etypecase expr - (null *movitz-nil*) - ((member t) (movitz-read 'muerte.cl:t)) - (symbol (intern-movitz-symbol expr)) - (integer (make-movitz-integer expr)) - (character (make-movitz-character expr)) - (string (or (gethash expr (image-string-constants *image*)) - (setf (gethash expr (image-string-constants *image*)) - (make-movitz-string expr)))) - (vector (make-movitz-vector (length expr) - :element-type (array-element-type expr) - :initial-contents expr)) - (cons - (or (gethash expr (image-cons-constants *image*)) - (setf (gethash expr (image-cons-constants *image*)) - (if (eq '#0=#:error (ignore-errors (when (not (list-length expr)) '#0#))) - (multiple-value-bind (unfolded-expr cdr-index) - (unfold-circular-list expr) - (let ((result (movitz-read unfolded-expr))) - (setf (movitz-last-cdr result) - (movitz-nthcdr cdr-index result)) - result)) - (make-movitz-cons (movitz-read (car expr)) - (movitz-read (cdr expr))))))) - (hash-table - (make-movitz-hash-table expr)) - (structure-object - (let ((slot-descriptions (gethash (type-of expr) - (image-struct-slot-descriptions *image*) - nil))) - (unless slot-descriptions - (error "Don't know how to movitz-read struct: ~S" expr)) - (let ((movitz-object (make-instance 'movitz-struct - :class (muerte::movitz-find-class (type-of expr)) - :length (length slot-descriptions)))) - (setf (image-lisp-to-movitz-object *image* expr) movitz-object) - (setf (slot-value movitz-object 'slot-values) - (mapcar #'(lambda (slot) - (movitz-read (slot-value expr (if (consp slot) (car slot) slot)))) - slot-descriptions)) - movitz-object)))))))) + (or (and (not re-read) + (let ((old-object (image-lisp-to-movitz-object *image* expr))) + (when (and old-object (not (gethash old-object *movitz-reader-clean-map*))) + (update-movitz-object old-object expr) + (setf (gethash old-object *movitz-reader-clean-map*) t)) + old-object)) + (setf (image-lisp-to-movitz-object *image* expr) + (etypecase expr + (null *movitz-nil*) + ((member t) (movitz-read 'muerte.cl:t)) + (symbol (intern-movitz-symbol expr)) + (integer (make-movitz-integer expr)) + (character (make-movitz-character expr)) + (string (or (gethash expr (image-string-constants *image*)) + (setf (gethash expr (image-string-constants *image*)) + (make-movitz-string expr)))) + (vector (make-movitz-vector (length expr) + :element-type (array-element-type expr) + :initial-contents expr)) + (cons + (or (gethash expr (image-cons-constants *image*)) + (setf (gethash expr (image-cons-constants *image*)) + (if (eq '#0=#:error (ignore-errors (when (not (list-length expr)) '#0#))) + (multiple-value-bind (unfolded-expr cdr-index) + (unfold-circular-list expr) + (let ((result (movitz-read unfolded-expr))) + (setf (movitz-last-cdr result) + (movitz-nthcdr cdr-index result)) + result)) + (make-movitz-cons (movitz-read (car expr)) + (movitz-read (cdr expr))))))) + (hash-table + (make-movitz-hash-table expr)) + (ratio + (let ((slot-descriptions (gethash 'muerte.cl::ratio + (image-struct-slot-descriptions *image*) + nil))) + (unless slot-descriptions + (error "Don't know how to movitz-read ratios (yet)." expr)) + (let ((movitz-object (make-instance 'movitz-struct + :class (muerte::movitz-find-class 'muerte.cl::ratio) + :length (length slot-descriptions)))) + (setf (image-lisp-to-movitz-object *image* expr) movitz-object) + (setf (slot-value movitz-object 'slot-values) + (list (movitz-read (numerator expr)) + (movitz-read (denominator expr)))) + movitz-object))) + (structure-object + (let ((slot-descriptions (gethash (type-of expr) + (image-struct-slot-descriptions *image*) + nil))) + (unless slot-descriptions + (error "Don't know how to movitz-read struct: ~S" expr)) + (let ((movitz-object (make-instance 'movitz-struct + :class (muerte::movitz-find-class (type-of expr)) + :length (length slot-descriptions)))) + (setf (image-lisp-to-movitz-object *image* expr) movitz-object) + (setf (slot-value movitz-object 'slot-values) + (mapcar #'(lambda (slot) + (movitz-read (slot-value expr (if (consp slot) (car slot) slot)))) + slot-descriptions)) + movitz-object)))))))) ;;;

1 0