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

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

06 Aug '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11652 Modified Files: special-operators.lisp Log Message: Don't barf when compiling + forms whose value is ignored, i.e. like (progn (+ a b) nil) Date: Fri Aug 6 07:45:30 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.33 movitz/special-operators.lisp:1.34 --- movitz/special-operators.lisp:1.33 Wed Jul 28 03:00:45 2004 +++ movitz/special-operators.lisp Fri Aug 6 07:45:30 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.33 2004/07/28 10:00:45 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.34 2004/08/06 14:45:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1029,13 +1029,17 @@ (define-special-operator muerte::++%2op (&all all &form form &env env &result-mode result-mode) (destructuring-bind (term1 term2) (cdr form) - (let ((returns (ecase (result-mode-type result-mode) - ((:function :multiple-values :eax :push) :eax) - ((:ebx :ecx :edx) result-mode) - ((:lexical-binding) result-mode)))) - (compiler-values () - :returns returns - :code `((:add ,(movitz-binding term1 env) ,(movitz-binding term2 env) ,returns)))))) + (if (eq :ignore result-mode) + (compiler-call #'compile-form-unprotected + :forward all + :form `(muerte.cl:progn term1 term2)) + (let ((returns (ecase (result-mode-type result-mode) + ((:function :multiple-values :eax :push) :eax) + ((:ebx :ecx :edx) result-mode) + ((:lexical-binding) result-mode)))) + (compiler-values () + :returns returns + :code `((:add ,(movitz-binding term1 env) ,(movitz-binding term2 env) ,returns))))))) (define-special-operator muerte::include (&form form) (let ((*require-dependency-chain*

1 0

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

06 Aug '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv14784 Modified Files: stream-image.lisp Log Message: Mostly minor tweaks to the movitz-image structures.. ie. some naming changes etc. Date: Fri Aug 6 07:43:55 2004 Author: ffjeld Index: movitz/stream-image.lisp diff -u movitz/stream-image.lisp:1.10 movitz/stream-image.lisp:1.11 --- movitz/stream-image.lisp:1.10 Wed Jul 28 03:00:59 2004 +++ movitz/stream-image.lisp Fri Aug 6 07:43:55 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.10 2004/07/28 10:00:59 ffjeld Exp $ +;;;; $Id: stream-image.lisp,v 1.11 2004/08/06 14:43:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -18,7 +18,7 @@ (in-package movitz) -(defclass stream-image (image) +(defclass stream-image (movitz-image) ((stream :reader image-stream :initarg :stream) @@ -36,7 +36,10 @@ (progn (format *query-io* "~&Please enter the stream-images NIL value: ") (read *query-io*))) - :reader image-nil-word))) + :reader image-nil-word) + (nil-object + :initform (make-movitz-nil) + :reader image-nil-object))) (defmethod image-register32 ((image stream-image) register-name) (declare (ignorable image) (ignore register-name)) @@ -64,14 +67,7 @@ (:character (make-instance 'movitz-character :char (code-char (ldb (byte 8 8) word)))) (:null - #+ignore - (assert (= (- word (tag :null)) (image-run-time-context-address image)) (word) - "The word #x~8,'0X has NIL tag but isn't NIL." word) - (setf (image-stream-position image) 0 #+ignore (- word (tag :null))) - (let ((object (read-binary 'movitz-run-time-context (image-stream image)))) - (setf (movitz-heap-object-word (movitz-run-time-context-null-symbol object)) - word) - object)) + (image-nil-object image)) (:symbol ;; (warn "loading new symbol at ~S" word) (setf (image-stream-position image)

1 0

[movitz-cvs] CVS update: movitz/procfs-image.lisp
by Frode Vatvedt Fjeld 06 Aug '04

06 Aug '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv13634 Modified Files: procfs-image.lisp Log Message: Mostly minor tweaks to the movitz-image structures.. ie. some naming changes etc. Date: Fri Aug 6 07:43:51 2004 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.13 movitz/procfs-image.lisp:1.14 --- movitz/procfs-image.lisp:1.13 Wed Jul 28 17:00:59 2004 +++ movitz/procfs-image.lisp Fri Aug 6 07:43:51 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.13 2004/07/29 00:00:59 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.14 2004/08/06 14:43:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -195,15 +195,16 @@ (typecase movitz-name (null (write-string "?") - (let* ((r (stack-frame-return-address stack-frame)) - (eax (get-word (+ (* 4 (interrupt-frame-index :eax)) stack-frame))) + (let* ((eax (get-word (+ (* 4 (interrupt-frame-index :eax)) stack-frame))) (ecx (get-word (+ (* 4 (interrupt-frame-index :ecx)) stack-frame))) + (edx (get-word (+ (* 4 (interrupt-frame-index :edx)) stack-frame))) (edi (get-word (+ (* 4 (interrupt-frame-index :edi)) stack-frame))) (eip (get-word (+ (* 4 (interrupt-frame-index :eip)) stack-frame))) + (esi (get-word (+ (* 4 (interrupt-frame-index :esi)) stack-frame))) (exception (get-word (+ (* 4 (interrupt-frame-index :exception)) stack-frame)))) - (when r (format t "#x~X (ret #x~X {EAX: #x~X, ECX: #x~X, EDI: #x~X, EIP: #x~X, exception ~D})" - stack-frame - r eax ecx edi eip exception)))) + (format t "#x~X {EAX: #x~X, ECX: #x~X, EDX: #x~X, EDI: #x~X, ESI: #x~X, EIP: #x~X, exception ~D}" + stack-frame + eax ecx edx edi esi eip exception))) (movitz-symbol (let ((name (movitz-print movitz-name))) (when print-frames

1 0

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

06 Aug '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv12407 Modified Files: image.lisp Log Message: Mostly minor tweaks to the movitz-image structures.. ie. some naming changes etc. Date: Fri Aug 6 07:43:46 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.61 movitz/image.lisp:1.62 --- movitz/image.lisp:1.61 Wed Aug 4 05:58:45 2004 +++ movitz/image.lisp Fri Aug 6 07:43:46 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.61 2004/08/04 12:58:45 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.62 2004/08/06 14:43:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -324,14 +324,6 @@ :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) -;;; (malloc-buffer -;;; :binary-type lu32 -;;; :initform 0) - (default-interrupt-trampoline - :map-binary-write 'movitz-intern-code-vector - :binary-tag :primitive-function - :map-binary-read-delayed 'movitz-word-code-vector - :binary-type code-vector-word) (classes ; A vector of class meta-objects. :initform nil ; The first element is the map of corresponding names :binary-type word @@ -355,12 +347,19 @@ (movitz-read-and-intern (funcall 'muerte::movitz-find-class x) 'word)) :map-binary-read-delayed 'movitz-word) - (interrupt-handlers + (exception-handlers :binary-type word :map-binary-write 'movitz-intern :map-binary-read-delayed 'movitz-word - :initarg :interrupt-handlers - :accessor movitz-run-time-context-interrupt-handlers) + :initarg :exception-handlers + :accessor movitz-run-time-context-exception-handlers) + (exception-handler-tails + :binary-type word + :initform nil + :map-binary-write 'movitz-read-and-intern + :map-binary-read-delayed 'movitz-word + :initarg :exception-handler-tails + :accessor movitz-run-time-context-exception-handler-tails) (interrupt-descriptor-table :binary-type word :accessor movitz-run-time-context-interrupt-descriptor-table @@ -538,7 +537,7 @@ :t-symbol (movitz-read 't) :null-symbol *movitz-nil*)) -(defclass image () +(defclass movitz-image () ((ds-segment-base :initform #x100000 :accessor image-ds-segment-base) @@ -546,7 +545,7 @@ :initform #x100000 :accessor image-cs-segment-base))) -(defclass symbolic-image (image) +(defclass symbolic-image (movitz-image) ((object-hash :accessor image-object-hash) ; object => address (address-hash @@ -861,7 +860,7 @@ (setf (movitz-symbol-value (movitz-read 'muerte:*build-number*)) (1+ *bootblock-build*)) (let ((handler (movitz-env-symbol-function 'muerte::interrupt-default-handler))) - (setf (movitz-run-time-context-interrupt-handlers (image-run-time-context *image*)) + (setf (movitz-run-time-context-exception-handlers (image-run-time-context *image*)) (movitz-read (make-array 256 :initial-element handler)))) (let ((load-address (image-start-address *image*))) (setf (image-cons-pointer *image*) (- load-address @@ -964,7 +963,7 @@ (assert (file-position stream 512) () ; leave room for bootblock. "Couldn't set file-position for ~W." (pathname stream)) (let* ((stack-vector (make-instance 'movitz-basic-vector - :num-elements #x1ffe + :num-elements #x2ffe :fill-pointer 0 :symbolic-data nil :element-type :u32)) @@ -1587,6 +1586,7 @@ (movitz-fixnum (movitz-fixnum-value expr)) (movitz-std-instance expr) + (movitz-struct expr) (movitz-heap-object (or (image-movitz-to-lisp-object *image* expr) (error "Unknown Movitz object: ~S" expr)))))

1 0

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

06 Aug '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv18113 Modified Files: compiler.lisp Log Message: Two substantial changes: Firstly the code for allocating &rest-lists on the stack is rewritten, because the old one didn't observe the stack discipline (causing weird bugs while experimenting with hw interrupts). Secondly, there was a bug/omission when lending optional-function-argument bindings to sub-functions, i.e like this: (defun foo (x &optional (y 0)) (lambda () (+ x (incf y)))) The code for foo in this case would be completely bogus, and e.g. over-write (car NIL) and generally ruin everyting. Date: Fri Aug 6 07:41:37 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.87 movitz/compiler.lisp:1.88 --- movitz/compiler.lisp:1.87 Wed Jul 28 17:12:54 2004 +++ movitz/compiler.lisp Fri Aug 6 07:41:37 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.87 2004/07/29 00:12:54 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.88 2004/08/06 14:41:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3404,7 +3404,7 @@ `((:cmpl :edi (:ebp ,(stack-frame-offset binding-location))) (:jne ',(operands result-mode))) (ecase (operator binding-location) - ((:eax :ebx) + ((:eax :ebx :edx) `((:cmpl :edi ,binding-location) (:jne ',(operands result-mode)))) (:argument-stack @@ -3415,7 +3415,7 @@ `((:cmpl :edi (:ebp ,(stack-frame-offset binding-location))) (:je ',(operands result-mode))) (ecase (operator binding-location) - ((:eax :ebx) + ((:eax :ebx :edx) `((:cmpl :edi ,binding-location) (:je ',(operands result-mode)))) (:argument-stack @@ -4264,6 +4264,10 @@ (function-argument-argnum binding))) unless (movitz-env-get optional-var 'ignore nil env nil) append + `((:init-lexvar ,binding)) + when supplied-p-binding + append `((:init-lexvar ,supplied-p-binding)) + append (compiler-values-bind (&code init-code-edx &producer producer) (compiler-call #'compile-form :form (optional-function-argument-init-form binding) @@ -4379,7 +4383,7 @@ (append #+ignore (make-immediate-move rest-position :edx) `(#+ignore (:call (:edi ,(global-constant-offset 'restify-dynamic-extent))) (:init-lexvar ,rest-binding - :init-with-register :eax + :init-with-register :edx :init-with-type list))))) (cond ;; &key processing.. @@ -5942,7 +5946,7 @@ (append (cond ((typep binding 'rest-function-argument) - (assert (eq :eax init-with-register)) + (assert (eq :edx init-with-register)) (assert (or (typep binding 'hidden-rest-function-argument) (movitz-env-get (binding-name binding) 'dynamic-extent nil (binding-env binding))) @@ -5951,13 +5955,47 @@ (setf (need-normalized-ecx-p (find-function-env (binding-env binding) funobj)) t) - (append (make-immediate-move (function-argument-argnum binding) :edx) - `((:call (:edi ,(global-constant-offset 'restify-dynamic-extent)))) - #+ignore - (unless (or (typep binding 'hidden-rest-function-argument) - (movitz-env-get (binding-name binding) - 'dynamic-extent nil (binding-env binding))) - (make-compiled-funcall-by-symbol 'muerte.cl:copy-list 1 funobj))))) + (let ((restify-alloca-loop (gensym "alloca-loop-")) + (restify-done (gensym "restify-done-")) + (restify-at-one (gensym "restify-at-one-")) + (restify-loop (gensym "restify-loop-"))) + (append + ;; (make-immediate-move (function-argument-argnum binding) :edx) + ;; `((:call (:edi ,(global-constant-offset 'restify-dynamic-extent)))) + ;; Make space for (1+ (* 2 (- ECX rest-pos))) words on the stack. + ;; Factor two is for one cons-cell per word, 1 is for 8-byte alignment. + `((:movl :edi :edx) + (:subl ,(function-argument-argnum binding) :ecx) + (:jbe ',restify-done) + (:leal ((:ecx 8) 4) :edx) ; EDX is fixnum counter + ,restify-alloca-loop + (:pushl :edi) + (:subl 4 :edx) + (:jnz ',restify-alloca-loop) + (:leal (:esp 5) :edx) + (:andl -7 :edx)) ; Make EDX a proper consp into the alloca area. + (cond + ((= 0 (function-argument-argnum binding)) + `((:movl :eax (:edx -1)) + (:movl :edx :eax) + (:subl 1 :ecx) + (:jz ',restify-done) + (:addl 8 :eax) + (:movl :eax (:eax -5)))) + (t `((:movl :edx :eax)))) + (when (>= 1 (function-argument-argnum binding)) + `((:jmp ',restify-at-one))) + `(,restify-loop + (:movl (:ebp (:ecx 4) 4) :ebx) + ,restify-at-one + (:movl :ebx (:eax -1)) + (:subl 1 :ecx) + (:jz ',restify-done) + (:addl 8 :eax) + (:movl :eax (:eax -5)) + (:jmp ',restify-loop) + ,restify-done) + )))) (cond ((binding-lended-p binding) (let* ((cons-position (getf (binding-lended-p binding)

1 0

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

04 Aug '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25249 Modified Files: ratios.lisp Log Message: Err.. this is from where the %ratio accessor compiler-macros were moved. Date: Wed Aug 4 06:01:14 2004 Author: ffjeld Index: movitz/losp/muerte/ratios.lisp diff -u movitz/losp/muerte/ratios.lisp:1.5 movitz/losp/muerte/ratios.lisp:1.6 --- movitz/losp/muerte/ratios.lisp:1.5 Sat Jul 31 16:35:09 2004 +++ movitz/losp/muerte/ratios.lisp Wed Aug 4 06:01:14 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.5 2004/07/31 23:35:09 ffjeld Exp $ +;;;; $Id: ratios.lisp,v 1.6 2004/08/04 13:01:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -39,15 +39,9 @@ (defun ratio-p (x) (typep x 'ratio)) -(define-compiler-macro %ratio-numerator (x) - `(memref ,x ,(bt:slot-offset 'movitz::movitz-ratio 'movitz::numerator) 0 :lisp)) - (defun ratio-numerator (x) (check-type x ratio) (%ratio-numerator x)) - -(define-compiler-macro %ratio-denominator (x) - `(memref ,x ,(bt:slot-offset 'movitz::movitz-ratio 'movitz::denominator) 0 :lisp)) (defun ratio-denominator (x) (check-type x ratio)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp
by Frode Vatvedt Fjeld 04 Aug '04

04 Aug '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv8704 Modified Files: primitive-functions.lisp Log Message: Removed some dead debugging code. Date: Wed Aug 4 06:00:33 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.36 movitz/losp/muerte/primitive-functions.lisp:1.37 --- movitz/losp/muerte/primitive-functions.lisp:1.36 Sat Jul 31 16:35:03 2004 +++ movitz/losp/muerte/primitive-functions.lisp Wed Aug 4 06:00:33 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.36 2004/07/31 23:35:03 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.37 2004/08/04 13:00:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -430,7 +430,6 @@ (:leal (:ebx :ecx) :edx) ; new roof to EDX (:cmpl :edx (:eax)) ; end of buffer? (:jl '(:sub-program (failed) - (:movl (:eax) :esi) (:int 112) (:halt) (:jmp 'failed))) @@ -455,7 +454,6 @@ (:leal (:ebx :ecx) :edx) ; new roof to EDX (:cmpl :edx (:eax)) ; end of buffer? (:jl '(:sub-program (failed) - (:movl (:eax) :esi) (:int 112) (:halt) (:jmp 'failed)))

1 0

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

04 Aug '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9154 Modified Files: integers.lisp Log Message: Moved %ratio accessor compiler-macros to arithmetic-macros.lisp. Date: Wed Aug 4 05:59:23 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.90 movitz/losp/muerte/integers.lisp:1.91 --- movitz/losp/muerte/integers.lisp:1.90 Sat Jul 31 17:37:31 2004 +++ movitz/losp/muerte/integers.lisp Wed Aug 4 05:59:23 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.90 2004/08/01 00:37:31 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.91 2004/08/04 12:59:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2228,7 +2228,7 @@ (values n 0) (multiple-value-bind (r q) (floor (%ratio-numerator n) (%ratio-denominator n)) - (values r (%make-rational q (%ratio-denominator n)))))) + (values r (make-rational q (%ratio-denominator n)))))) (2 (n divisor) (multiple-value-bind (q r) (truncate n divisor)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/arithmetic-macros.lisp
by Frode Vatvedt Fjeld 04 Aug '04

04 Aug '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv8035 Modified Files: arithmetic-macros.lisp Log Message: Moved %ratio accessor compiler-macros to arithmetic-macros.lisp. Date: Wed Aug 4 05:59:18 2004 Author: ffjeld Index: movitz/losp/muerte/arithmetic-macros.lisp diff -u movitz/losp/muerte/arithmetic-macros.lisp:1.5 movitz/losp/muerte/arithmetic-macros.lisp:1.6 --- movitz/losp/muerte/arithmetic-macros.lisp:1.5 Fri Jul 23 08:35:23 2004 +++ movitz/losp/muerte/arithmetic-macros.lisp Wed Aug 4 05:59:18 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Jul 17 13:42:46 2004 ;;;; -;;;; $Id: arithmetic-macros.lisp,v 1.5 2004/07/23 15:35:23 ffjeld Exp $ +;;;; $Id: arithmetic-macros.lisp,v 1.6 2004/08/04 12:59:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -486,3 +486,10 @@ (:jnc 'done) (:addl ,movitz:+movitz-fixnum-factor+ :eax) done)) + +(define-compiler-macro %ratio-numerator (x) + `(memref ,x ,(bt:slot-offset 'movitz::movitz-ratio 'movitz::numerator) 0 :lisp)) + +(define-compiler-macro %ratio-denominator (x) + `(memref ,x ,(bt:slot-offset 'movitz::movitz-ratio 'movitz::denominator) 0 :lisp)) +

1 0

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

04 Aug '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv19715 Modified Files: image.lisp Log Message: Slightly improved disassembly of primitive-functions. Date: Wed Aug 4 05:58:46 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.60 movitz/image.lisp:1.61 --- movitz/image.lisp:1.60 Sat Jul 31 17:37:22 2004 +++ movitz/image.lisp Wed Aug 4 05:58:45 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.60 2004/08/01 00:37:22 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.61 2004/08/04 12:58:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1288,12 +1288,12 @@ (slot-offset 'movitz-funobj 'constant0)) 4) (movitz-funobj-const-list funobj))) - when (and funobj (typep operand 'ia-x86::operand-rel-pointer)) + when (typep operand 'ia-x86::operand-rel-pointer) collect (let* ((x (+ pc (imagpart (ia-x86::instruction-original-datum instruction)) (length (ia-x86:instruction-prefixes instruction)) (ia-x86::operand-offset operand))) - (label (car (find x (movitz-funobj-symtab funobj) :key #'cdr)))) + (label (and funobj (car (find x (movitz-funobj-symtab funobj) :key #'cdr))))) (if label (format nil "branch to ~S at ~D" label x) (format nil "branch to ~D" x)))

1 0