movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

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

21 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv14980 Modified Files: hash-tables.lisp Log Message: Have the index type take a 'step' parameters. Date: Sun Aug 21 19:56:41 2005 Author: ffjeld Index: movitz/losp/muerte/hash-tables.lisp diff -u movitz/losp/muerte/hash-tables.lisp:1.8 movitz/losp/muerte/hash-tables.lisp:1.9 --- movitz/losp/muerte/hash-tables.lisp:1.8 Thu Jun 16 12:00:51 2005 +++ movitz/losp/muerte/hash-tables.lisp Sun Aug 21 19:56:40 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.8 2005/06/16 10:00:51 ffjeld Exp $ +;;;; $Id: hash-tables.lisp,v 1.9 2005/08/21 17:56:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -120,7 +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)) + (declare (type (index 2) i2)) (do () (nil) (let ((k (svref%unsafe bucket i2))) (cond

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp
by ffjeld＠common-lisp.net 21 Aug '05

21 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv14950 Modified Files: los-closette.lisp Log Message: sync Date: Sun Aug 21 19:55:54 2005 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.34 movitz/losp/muerte/los-closette.lisp:1.35 --- movitz/losp/muerte/los-closette.lisp:1.34 Sun Aug 14 20:50:12 2005 +++ movitz/losp/muerte/los-closette.lisp Sun Aug 21 19:55:54 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.34 2005/08/14 18:50:12 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.35 2005/08/21 17:55:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1310,11 +1310,13 @@ (and (slot-missing class object slot-name 'slot-boundp) t) (slot-boundp-using-class class object slot)))) -(defmethod slot-boundp-using-class ((class standard-class) object (slot standard-effective-slot-definition)) +(defmethod slot-boundp-using-class + ((class standard-class) object (slot standard-effective-slot-definition)) (not (eq (load-global-constant new-unbound-value) (standard-instance-access object (slot-definition-location slot))))) -(defmethod slot-boundp-using-class ((class funcallable-standard-class) object (slot standard-effective-slot-definition)) +(defmethod slot-boundp-using-class + ((class funcallable-standard-class) object (slot standard-effective-slot-definition)) (not (eq (load-global-constant new-unbound-value) (svref (std-gf-instance-slots object) (slot-definition-location slot))))) @@ -1329,12 +1331,14 @@ object) (slot-makunbound-using-class class object slot)))) -(defmethod slot-makunbound-using-class ((class standard-class) object (slot standard-effective-slot-definition)) +(defmethod slot-makunbound-using-class + ((class standard-class) object (slot standard-effective-slot-definition)) (setf (standard-instance-access object (slot-definition-location slot)) (load-global-constant new-unbound-value)) object) -(defmethod slot-makunbound-using-class ((class funcallable-standard-class) object (slot standard-effective-slot-definition)) +(defmethod slot-makunbound-using-class + ((class funcallable-standard-class) object (slot standard-effective-slot-definition)) (setf (svref (std-gf-instance-slots object) (slot-definition-location slot)) (load-global-constant new-unbound-value)) object)

1 0

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

21 Aug '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv14922 Modified Files: compiler.lisp Log Message: sync Date: Sun Aug 21 19:51:53 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.151 movitz/compiler.lisp:1.152 --- movitz/compiler.lisp:1.151 Sun Aug 21 17:27:19 2005 +++ movitz/compiler.lisp Sun Aug 21 19:51:53 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.151 2005/08/21 15:27:19 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.152 2005/08/21 17:51:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -6920,6 +6920,12 @@ `((:movl :eax ,destination)))) (binding (make-store-lexical destination :eax nil funobj frame-map)))))))) + ((and (movitz-subtypep result-type '(unsigned-byte 32)) + (warn "Unknown u32 ADD: ~A/~S = ~A/~S + ~A/~S" + destination-location + destination + loc0 term0 + loc1 term1))) (t (append (cond ((type-specifier-singleton type0) (append (make-load-lexical term1 :eax funobj nil frame-map)

1 0

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

21 Aug '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv14897 Modified Files: compiler-types.lisp Log Message: Fixed bug in lookup of deftypes at compile-time. Date: Sun Aug 21 19:51:34 2005 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.23 movitz/compiler-types.lisp:1.24 --- movitz/compiler-types.lisp:1.23 Sat Aug 20 22:30:14 2005 +++ movitz/compiler-types.lisp Sun Aug 21 19:51:34 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.23 2005/08/20 20:30:14 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.24 2005/08/21 17:51:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -499,9 +499,8 @@ (type-values 'cons :members '(nil))) (sequence (type-values '(vector cons) :members '(nil))) - (t (let ((deriver (and (boundp 'muerte::*compiler-derived-typespecs*) - (gethash type-specifier - (symbol-value 'muerte::*compiler-derived-typespecs*))))) + (t (let ((deriver (and (boundp '*image*) + (gethash type-specifier muerte::*compiler-derived-typespecs*)))) (if deriver (type-specifier-encode (funcall deriver)) (type-values () :include (list type-specifier))))))) @@ -563,10 +562,10 @@ (type-values () :include (list type-specifier))))) ((array vector binding-type) (type-values () :include (list type-specifier))) - (t (let ((deriver (and (boundp 'muerte::*compiler-derived-typespecs*) - (gethash (intern (symbol-name (car type-specifier)) - :muerte.cl) - (symbol-value 'muerte::*compiler-derived-typespecs*))))) + (t (let ((deriver (and (boundp '*image*) + (gethash (translate-program (car type-specifier) + :cl :muerte.cl) + muerte::*compiler-derived-typespecs*)))) (assert deriver (type-specifier) "Unknown type ~S." type-specifier) (type-specifier-encode (apply deriver (cdr type-specifier))))))))))

1 0

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

21 Aug '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv4805 Modified Files: compiler.lisp Log Message: Improved :add extended-code. Date: Sun Aug 21 17:27:19 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.150 movitz/compiler.lisp:1.151 --- movitz/compiler.lisp:1.150 Sat Aug 20 22:30:40 2005 +++ movitz/compiler.lisp Sun Aug 21 17:27: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.150 2005/08/20 20:30:40 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.151 2005/08/21 15:27:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3066,33 +3066,6 @@ (warn "Unused variable: ~S" (binding-name binding)))) ((not (plusp (or (car (gethash binding var-counts)) 0)))))) - collect binding) - #+ignore - (loop for (variable . binding) in (movitz-environment-bindings env) - unless (cond - ((not (typep binding 'lexical-binding))) - ((typep binding 'lambda-binding)) - ((typep binding 'constant-object-binding)) - ((typep binding 'forwarding-binding) - ;; Immediately "assign" to target. - (when (plusp (or (car (gethash binding var-counts)) 0)) - (setf (new-binding-location binding frame-map) - (forwarding-binding-target binding))) - t) - ((typep binding 'borrowed-binding)) - ((typep binding 'funobj-binding)) - ((and (typep binding 'fixed-required-function-argument) - (plusp (or (car (gethash binding var-counts)) 0))) - (prog1 nil ; may need lending-cons - (setf (new-binding-location binding frame-map) - `(:argument-stack ,(function-argument-argnum binding))))) - ((unless (or (movitz-env-get variable 'ignore nil env nil) - (movitz-env-get variable 'ignorable nil env nil) - (typep binding 'hidden-rest-function-argument) - (third (gethash binding var-counts))) - (warn "Unused variable: ~S" - (binding-name binding)))) - ((not (plusp (or (car (gethash binding var-counts)) 0))))) collect binding)) (bindings-fun-arg-sorted (when (eq env function-env) @@ -3145,6 +3118,13 @@ (when bindings-to-locate (dox (binding-env (first bindings-to-locate)) #'movitz-environment-uplink))))) + #+ignore + (loop for binding in bindings-to-locate + do (when (binding-store-type binding) + (warn "~S => ~S" binding (binding-store-type binding))) + (when (typep (binding-store-type binding) 'lexical-binding) + (warn "binding ~S == ~S" + binding (binding-store-type binding)))) ;; First, make several passes while trying to locate bindings ;; into registers. (loop repeat 100 with try-again = t and did-assign = t @@ -6835,72 +6815,111 @@ ((and (movitz-subtypep type0 'fixnum) (movitz-subtypep type1 'fixnum) (movitz-subtypep result-type 'fixnum)) - #+ignore (warn "ADDX: ~S" instruction) - (cond - ((and (type-specifier-singleton type0) - (eq loc1 destination-location)) + (let ((constant0 (let ((x (type-specifier-singleton type0))) + (when x (movitz-immediate-value (car x))))) + (constant1 (let ((x (type-specifier-singleton type1))) + (when x (movitz-immediate-value (car x)))))) + (assert (not (and constant0 (zerop constant0)))) + (assert (not (and constant1 (zerop constant1)))) (cond - ((member destination-location '(:eax :ebx :ecx :edx)) - `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) - ,destination))) - ((integerp loc1) - ;; (break "check that this is correct..") - `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) - (:ebp ,(stack-frame-offset loc1))))) - ((eq :argument-stack (operator loc1)) - `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) - (:ebp ,(argument-stack-offset (binding-target term1)))))) - (t (error "Don't know how to add this for loc1 ~S" loc1)))) - ((and (type-specifier-singleton type0) - (eq term1 destination) - (integerp destination-location)) - (break "untested") - `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) - (:ebp ,(stack-frame-offset destination-location))))) - ((and (type-specifier-singleton type0) - (symbolp loc1) - (integerp destination-location)) - (append `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) - ,loc1)) - (make-store-lexical destination loc1 nil funobj frame-map))) - ((and (integerp loc0) (integerp loc1) - (member destination-location '(:eax :ebx :ecx :edx))) - (append `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location) - (:addl (:ebp ,(stack-frame-offset loc1)) ,destination-location)))) - (t (warn "ADD: ~A/~S = ~A/~S + ~A/~S" - destination-location - destination - loc0 term0 - loc1 term1) - #+ignore (warn "map: ~A" frame-map) + ((and constant0 + (equal loc1 destination-location)) + (cond + ((member destination-location '(:eax :ebx :ecx :edx)) + `((:addl ,constant0 ,destination-location))) + ((integerp loc1) + `((:addl ,constant0 (:ebp ,(stack-frame-offset loc1))))) + ((eq :argument-stack (operator loc1)) + `((:addl ,constant0 + (:ebp ,(argument-stack-offset (binding-target term1)))))) + (t (error "Don't know how to add this for loc1 ~S" loc1)))) + ((and constant0 + (integerp destination-location) + (eql term1 destination-location)) + (break "untested") + `((:addl ,constant0 (:ebp ,(stack-frame-offset destination-location))))) + ((and constant0 + (integerp destination-location) + (member loc1 '(:eax :ebx :ecx :edx))) + (break "check this!") + `((:addl ,constant0 ,loc1) + (:movl ,loc1 (:ebp ,(stack-frame-offset destination-location))))) + ((and (integerp loc0) + (integerp loc1) + (member destination-location '(:eax :ebx :ecx :edx))) + (append `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location) + (:addl (:ebp ,(stack-frame-offset loc1)) ,destination-location)))) + ((and (integerp destination-location) + (eql loc0 destination-location) + constant1) + `((:addl ,constant1 (:ebp ,(stack-frame-offset destination-location))))) + ((and (integerp destination-location) + (eql loc1 destination-location) + constant0) + `((:addl ,constant0 (:ebp ,(stack-frame-offset destination-location))))) + ((and (member destination-location '(:eax :ebx :ecx :edx)) + (eq loc0 :untagged-fixnum-ecx) + constant1) + `((:leal ((:ecx ,+movitz-fixnum-factor+) ,constant1) + ,destination-location))) + ((and (member destination-location '(:eax :ebx :ecx :edx)) + (integerp loc1) + constant0) + `((:movl (:ebp ,(stack-frame-offset loc1)) ,destination-location) + (:addl ,constant0 ,destination-location))) + ((and (member destination-location '(:eax :ebx :ecx :edx)) + (integerp loc0) + constant1) + `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location) + (:addl ,constant1 ,destination-location))) + ((and (member destination-location '(:eax :ebx :ecx :edx)) + (integerp loc0) + (member loc1 '(:eax :ebx :ecx :edx)) + (not (eq destination-location loc1))) + `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location) + (:addl ,loc1 ,destination-location))) + ((and (member destination-location '(:eax :ebx :ecx :edx)) + constant0 + (member loc1 '(:eax :ebx :ecx :edx))) + `((:leal (,loc1 ,constant0) ,destination-location))) + ((and (member destination-location '(:eax :ebx :ecx :edx)) + constant1 + (member loc0 '(:eax :ebx :ecx :edx))) + `((:leal (,loc0 ,constant1) ,destination-location))) + (t (warn "Unknown fixnum ADD: ~A/~S = ~A/~S + ~A/~S" + destination-location + destination + loc0 term0 + loc1 term1) + #+ignore (warn "map: ~A" frame-map) ;;; (warn "ADDI: ~S" instruction) - (append (cond - ((type-specifier-singleton type0) - (append (make-load-lexical term1 :eax funobj nil frame-map) - (make-load-constant (car (type-specifier-singleton type0)) - :ebx funobj frame-map))) - ((type-specifier-singleton type1) - (append (make-load-lexical term0 :eax funobj nil frame-map) - (make-load-constant (car (type-specifier-singleton type1)) - :ebx funobj frame-map))) - ((and (eq :eax loc0) (eq :ebx loc1)) - nil) - ((and (eq :ebx loc0) (eq :eax loc1)) - nil) ; terms order isn't important - ((eq :eax loc1) - (append - (make-load-lexical term0 :ebx funobj nil frame-map))) - (t (append - (make-load-lexical term0 :eax funobj nil frame-map) - (make-load-lexical term1 :ebx funobj nil frame-map)))) - `((:movl (:edi ,(global-constant-offset '+)) :esi)) - (make-compiled-funcall-by-esi 2) - (etypecase destination - (symbol - (unless (eq destination :eax) - `((:movl :eax ,destination)))) - (binding - (make-store-lexical destination :eax nil funobj frame-map))))))) + (append (cond + ((type-specifier-singleton type0) + (append (make-load-lexical term1 :eax funobj nil frame-map) + (make-load-constant (car (type-specifier-singleton type0)) + :ebx funobj frame-map))) + ((type-specifier-singleton type1) + (append (make-load-lexical term0 :eax funobj nil frame-map) + (make-load-constant (car (type-specifier-singleton type1)) + :ebx funobj frame-map))) + ((and (eq :eax loc0) (eq :ebx loc1)) + nil) + ((and (eq :ebx loc0) (eq :eax loc1)) + nil) ; terms order isn't important + ((eq :eax loc1) + (append + (make-load-lexical term0 :ebx funobj nil frame-map))) + (t (append + (make-load-lexical term0 :eax funobj nil frame-map) + (make-load-lexical term1 :ebx funobj nil frame-map)))) + `((:movl (:edi ,(global-constant-offset '+)) :esi)) + (make-compiled-funcall-by-esi 2) + (etypecase destination + (symbol + (unless (eq destination :eax) + `((:movl :eax ,destination)))) + (binding + (make-store-lexical destination :eax nil funobj frame-map)))))))) (t (append (cond ((type-specifier-singleton type0) (append (make-load-lexical term1 :eax funobj nil frame-map)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette-compiler.lisp
by ffjeld＠common-lisp.net 21 Aug '05

21 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv31324 Modified Files: los-closette-compiler.lisp Log Message: Some minor code cleanups. Date: Sun Aug 21 15:47:53 2005 Author: ffjeld Index: movitz/losp/muerte/los-closette-compiler.lisp diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.17 movitz/losp/muerte/los-closette-compiler.lisp:1.18 --- movitz/losp/muerte/los-closette-compiler.lisp:1.17 Thu May 5 17:17:35 2005 +++ movitz/losp/muerte/los-closette-compiler.lisp Sun Aug 21 15:47:53 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.17 2005/05/05 15:17:35 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.18 2005/08/21 13:47:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,8 +28,6 @@ (define-compile-time-variable *the-position-of-standard-effective-slots* nil) (define-compile-time-variable *the-class-standard-class* nil) -(defvar *the-effective-slot-positions* nil) - (eval-when (:compile-toplevel) ; extends to EOF (defvar *classes-with-old-slot-definitions* nil) @@ -521,18 +519,17 @@ val))) (defun (setf std-slot-value) (value instance slot-name) - (setq slot-name (translate-program slot-name :cl :muerte.cl)) - (let* ((location (slot-location (movitz-class-of instance) slot-name)) + (let* ((location (slot-location (movitz-class-of instance) + (translate-program slot-name :cl :muerte.cl))) (slots (std-instance-slots instance))) (setf (svref slots location) (muerte::translate-program value :cl :muerte.cl)))) - (defun movitz-slot-value (object slot-name) - (setq slot-name (translate-program slot-name :cl :muerte.cl)) - (std-slot-value object slot-name)) + (defun movitz-slot-vale (object slot-name) + (std-slot-value object (translate-program slot-name :cl :muerte.cl))) (defun (setf movitz-slot-value) (new-value object slot-name) - (setq slot-name (translate-program slot-name :cl :muerte.cl)) - (setf (std-slot-value object slot-name) new-value)) + (setf (std-slot-value object (translate-program slot-name :cl :muerte.cl)) + new-value)) (defun std-slot-exists-p (instance slot-name) (not (null (find slot-name (class-slots (movitz-class-of instance)) @@ -577,27 +574,6 @@ :name name all-keys))) (setf (movitz-find-class name) class))))) -;;; (when old-class -;;; -;;; (let ( -;;; (cond -;;; (old-class -;;; (setf (std-instance-class old-class) (std-instance-class new-class) -;;; (std-instance-slots old-class) (std-instance-slots new-class) -;;; (std-instance-class new-class) (movitz::movitz-read 'dead-class-instance!) -;;; (std-instance-slots new-class) (movitz::movitz-read 'dead-class-instance!) -;;; (class-precedence-list old-class) (std-compute-class-precedence-list old-class)) -;;; (let ((supers (class-direct-superclasses old-class))) -;;; (dolist (superclass supers) -;;; (setf (class-direct-subclasses superclass) -;;; (delete new-class (class-direct-subclasses superclass))) -;;; (pushnew old-class (class-direct-subclasses superclass)))) -;;; old-class) -;;; ((not old-class) -;;; (setf (movitz-find-class name) new-class) -;;; new-class))))) - -;;; (defun movitz-make-instance-funcallable (metaclass &rest all-keys &key name direct-superclasses direct-slots &allow-other-keys) (declare (ignore all-keys)) @@ -1134,7 +1110,7 @@ (generic-function-lambda-list gf) lambda-list (generic-function-methods gf) () (generic-function-method-class gf) method-class - (generic-function-method-combination gf) (symbol-value '*the-standard-method-combination*)) + (generic-function-method-combination gf) *the-standard-method-combination*) (finalize-generic-function gf) gf))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp
by ffjeld＠common-lisp.net 21 Aug '05

21 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv31296 Modified Files: basic-macros.lisp Log Message: Have compile-time-variables be per-image (on the host side), by way of defining them as symbol-macros that expand to getf on an *image* slot. Date: Sun Aug 21 15:47:20 2005 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.63 movitz/losp/muerte/basic-macros.lisp:1.64 --- movitz/losp/muerte/basic-macros.lisp:1.63 Sat Aug 20 22:25:09 2005 +++ movitz/losp/muerte/basic-macros.lisp Sun Aug 21 15:47:20 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.63 2005/08/20 20:25:09 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.64 2005/08/21 13:47:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -156,11 +156,12 @@ (let ((the-value (eval value))) `(progn (eval-when (:compile-toplevel) - (defvar ,name) - (unless (member ',name (movitz::image-compile-time-variables movitz::*image*)) - (setf ,name ',the-value) - (push ',name (movitz::image-compile-time-variables movitz::*image*)))) - (defvar ,name 'uninitialized-compile-time-variable)))) + (define-symbol-macro ,name + (getf (movitz::image-compile-time-variables movitz::*image*) + ',name)) + (setf ,name (or ,name ',the-value))) + (eval-when (:load-toplevel :excute) + (defvar ,name 'uninitialized-compile-time-variable))))) (defmacro let* (var-list &body declarations-and-body) (multiple-value-bind (body declarations)

1 0

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

21 Aug '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv31279 Modified Files: image.lisp Log Message: Have compile-time-variables be per-image (on the host side), by way of defining them as symbol-macros that expand to getf on an *image* slot. Date: Sun Aug 21 15:47:16 2005 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.103 movitz/image.lisp:1.104 --- movitz/image.lisp:1.103 Sun Aug 21 14:11:41 2005 +++ movitz/image.lisp Sun Aug 21 15:47:16 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.103 2005/08/21 12:11:41 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.104 2005/08/21 13:47:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -923,9 +923,9 @@ :cl :muerte.cl)))) (t (warn "not a symbol for plist: ~S has ~S" symbol plist))))) ;; pull in global properties - (loop for var in (image-compile-time-variables *image*) + (loop for (var value) on (image-compile-time-variables *image*) by #'cddr do (let ((mname (movitz-read var)) - (mvalue (movitz-read (symbol-value var)))) + (mvalue (movitz-read value))) (setf (movitz-symbol-value mname) mvalue))) (setf (movitz-symbol-value (movitz-read 'muerte::*packages*)) (movitz-read (make-packages-hash))))

1 0

[movitz-cvs] CVS update: movitz/movitz-mode.el
by ffjeld＠common-lisp.net 21 Aug '05

21 Aug '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24547 Modified Files: movitz-mode.el Log Message: Added movitz-disassemble-method, and use it in movitz-mode.el. Date: Sun Aug 21 14:12:01 2005 Author: ffjeld Index: movitz/movitz-mode.el diff -u movitz/movitz-mode.el:1.9 movitz/movitz-mode.el:1.10 --- movitz/movitz-mode.el:1.9 Sat Apr 30 23:19:42 2005 +++ movitz/movitz-mode.el Sun Aug 21 14:11:51 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Sep 27 18:12:17 2001 ;;;; -;;;; $Id: movitz-mode.el,v 1.9 2005/04/30 21:19:42 ffjeld Exp $ +;;;; $Id: movitz-mode.el,v 1.10 2005/08/21 12:11:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -107,9 +107,10 @@ (dont-run-bochs-p (message "Dumping Movitz image...done. Bootblock ID: %d. Running qemu.." (fi:eval-in-lisp "movitz::*bootblock-build*")) - (call-process "/bin/sh" nil 0 nil "-c" - (format "DISPLAY=\"%s\" cd ~/clnet/movitz && qemu -fda los0-image -boot a" - display-shortcut))) +;; (call-process "/bin/sh" nil 0 nil "-c" +;; (format "DISPLAY=\"%s\" cd ~/clnet/movitz && qemu -fda los0-image -boot a" +;; display-shortcut)) + ) (t (message "Dumping Movitz image...done. Bootblock ID: %d. Running bochs on \"%s\"..." (fi:eval-in-lisp "movitz::*bootblock-build*") display-shortcut) @@ -212,25 +213,13 @@ ((string= "method" defun-type) (message "Movitz disassembling %s %s %s..." defun-type defun-name lambda-list) (fi:eval-in-lisp - "(cl:let* ((method-name (cl:let ((cl:*package* (cl:find-package :%s))) + "(cl:let* ((gf-name (cl:let ((cl:*package* (cl:find-package :%s))) (cl:read-from-string \"%s\"))) - (gf (movitz::movitz-env-named-function method-name)) (qualifiers (cl:read-from-string \"%s\")) (lambda-list (cl:let ((cl:*package* (cl:find-package :%s))) (cl:read-from-string \"%s\"))) - (specializing-lambda-list - (cl:subseq lambda-list 0 - (cl:position-if (cl:lambda (x) - (cl:and (cl:symbolp x) - (cl:char= #\\& (cl:char (cl:string x) 0)))) - lambda-list))) - (specializers (cl:mapcar #'muerte::find-specializer - (cl:mapcar (cl:lambda (x) (cl:if (cl:consp x) (cl:second x) 'muerte.cl:t)) - specializing-lambda-list))) - (method (muerte::movitz-find-method gf qualifiers specializers)) - (funobj (muerte::movitz-slot-value method 'muerte::function)) (cl:*print-base* 16)) - (movitz::movitz-disassemble-funobj funobj))" + (movitz::movitz-disassemble-method gf-name lambda-list qualifiers))" fi:package defun-name options fi:package lambda-list) (switch-to-buffer "*common-lisp*") (message "Movitz disassembling %s %s...done." defun-type defun-name)) @@ -312,6 +301,7 @@ (put 'with-inline-assembly tag '(like prog)) (put 'with-inline-assembly-case tag '(like prog)) (put 'do-case tag '(like prog)) + (put 'select tag '(like case)) (put 'compiler-typecase tag '(like case)))

1 0

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

21 Aug '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24532 Modified Files: image.lisp Log Message: Added movitz-disassemble-method, and use it in movitz-mode.el. Date: Sun Aug 21 14:11:48 2005 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.102 movitz/image.lisp:1.103 --- movitz/image.lisp:1.102 Sat Aug 20 22:31:05 2005 +++ movitz/image.lisp Sun Aug 21 14:11:41 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.102 2005/08/20 20:31:05 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.103 2005/08/21 12:11:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1299,6 +1299,26 @@ (assert funobj (module) "No load funobj found for module ~S." module) (movitz-disassemble-funobj funobj :name module))) + +(defun movitz-disassemble-method (name lambda-list &optional qualifiers) + (let* ((gf (or (movitz-env-named-function name) + (error "No function named ~S." name))) + (specializing-lambda-list + (subseq lambda-list 0 + (position-if (lambda (x) + (and (symbolp x) + (char= #\& (char (string x) 0)))) + lambda-list))) + (specializers (mapcar #'muerte::find-specializer + (mapcar (lambda (x) + (if (consp x) + (second x) + 'muerte.cl::t)) + specializing-lambda-list))) + (method (muerte::movitz-find-method gf qualifiers specializers)) + (funobj (muerte::movitz-slot-value method 'muerte::function)) + (*print-base* 16)) + (movitz-disassemble-funobj funobj))) (defparameter *recursive-disassemble-remember-funobjs* nil)

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