movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[movitz-cvs] CVS movitz
by ffjeld 13 Mar '07

13 Mar '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv20593 Modified Files: image.lisp Log Message: Make NIL the default value for *image*. --- /project/movitz/cvsroot/movitz/image.lisp 2007/03/01 17:49:30 1.110 +++ /project/movitz/cvsroot/movitz/image.lisp 2007/03/13 20:40:06 1.111 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.110 2007/03/01 17:49:30 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.111 2007/03/13 20:40:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -779,9 +779,9 @@ :start-address start-address :movitz-features '(:movitz) :function-code-sizes - (if (and (boundp '*image*) *image*) + (if *image* (copy-hash-table (function-code-sizes *image*)) - (make-hash-table :test #'equal)) + (make-hash-table :test #'equal)) init-args))) (setf (image-nil-word *image*) (+ 5 (- (slot-offset 'movitz-run-time-context 'null-symbol) @@ -824,7 +824,7 @@ (when init-file (movitz-compile-file init-file)) *image*) - *i* (when (boundp '*image*) *image*)) + *i* *image*) (when gc #+allegro (setf (sys:gsgc-parameter :generation-spread) 8) #+allegro (excl:gc :tenure)

1 0

[movitz-cvs] CVS movitz
by ffjeld 13 Mar '07

13 Mar '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv15051 Removed Files: slime-movitz.el Log Message: Removed in favor of ide/movitz-slime.el

1 0

[movitz-cvs] CVS movitz/losp/lib
by ffjeld 12 Mar '07

12 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/lib In directory clnet:/tmp/cvs-serv14270 Modified Files: threading.lisp Log Message: Save EFLAGS correctly in yield (so that e.g IF is preserved across yield). --- /project/movitz/cvsroot/movitz/losp/lib/threading.lisp 2005/06/10 23:09:14 1.8 +++ /project/movitz/cvsroot/movitz/losp/lib/threading.lisp 2007/03/12 22:50:34 1.9 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Apr 28 08:30:01 2005 ;;;; -;;;; $Id: threading.lisp,v 1.8 2005/06/10 23:09:14 ffjeld Exp $ +;;;; $Id: threading.lisp,v 1.9 2007/03/12 22:50:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -179,7 +179,7 @@ (muerte::asm-register :esi)) () "Will not yield to a non-yield frame.") ;; Push eflags for later.. - (setf (memref (decf esp) 0) (eflags)) + (setf (memref (decf esp) 0 :type :unsigned-byte32) (eflags)) ;; Store EBP and ESP so we can get to them after the switch (setf (%run-time-context-slot target-rtc 'muerte::scratch1) ebp (%run-time-context-slot target-rtc 'muerte::scratch2) esp) @@ -194,5 +194,5 @@ (:movw :cx :fs) (:locally (:movl (:edi (:edi-offset scratch1)) :ebp)) (:locally (:movl (:edi (:edi-offset scratch2)) :esp)) - (:popfl))))) + (:popfl)))))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 12 Mar '07

12 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv5092 Modified Files: conditions.lisp Log Message: Minor tweaks. --- /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2007/03/11 22:43:32 1.23 +++ /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2007/03/12 21:53:40 1.24 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.23 2007/03/11 22:43:32 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.24 2007/03/12 21:53:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -230,7 +230,6 @@ "Signal the condition denoted by a condition designator. Will only make-instance a condition when it is required. Return the condition object, if there was one." - (declare (dynamic-extent arguments)) (let* ((class (etypecase datum (symbol (or (find-class datum nil) @@ -243,14 +242,14 @@ (condition nil) (bos-type *break-on-signals*)) (with-simple-restart (continue "Ignore *break-on-signals*.") - (let ((*break-on-signals* nil)) ; avoid recursive error if *b-o-s* is faulty. + (let ((*break-on-signals* nil)) ; avoid recursive error if *b-o-s* is faulty. (when (typecase bos-type (null nil) (symbol (let ((bos-class (find-class bos-type nil))) (if (not bos-class) (typep (class-prototype-value class) bos-type) - (member bos-class cpl)))) + (member bos-class cpl)))) (list (typep (class-prototype-value class) bos-type)) (t (member bos-type cpl))) @@ -259,7 +258,7 @@ `(funcall ,handler (or condition (setf condition - (coerce-to-condition default-type datum args)))))) + (coerce-to-condition default-type datum args)))))) (let ((*active-condition-handlers* *active-condition-handlers*)) (do () ((null *active-condition-handlers*)) (let ((handlers (pop *active-condition-handlers*))) @@ -270,9 +269,9 @@ (let ((handler-class (find-class handler-type nil))) (when (if (not handler-class) (typep (class-prototype-value class) handler-type) - (progn - (setf (car handler) handler-class) ; XXX memoize this find-class.. - (member handler-class cpl))) + (progn + (setf (car handler) handler-class) ; XXX memoize this find-class.. + (member handler-class cpl))) (invoke-handler (cdr handler))))) (cons (when (typep (class-prototype-value class) handler-type)

1 0

[movitz-cvs] CVS movitz/losp/lib
by ffjeld 11 Mar '07

11 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/lib In directory clnet:/tmp/cvs-serv14937 Modified Files: readline.lisp Log Message: Don't modify condition. --- /project/movitz/cvsroot/movitz/losp/lib/readline.lisp 2005/10/31 09:17:07 1.8 +++ /project/movitz/cvsroot/movitz/losp/lib/readline.lisp 2007/03/11 22:43:46 1.9 @@ -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.8 2005/10/31 09:17:07 ffjeld Exp $ +;;;; $Id: readline.lisp,v 1.9 2007/03/11 22:43:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -128,15 +128,12 @@ (write-string buffer t :end end) (setf (cursor-x console) (+ cursor-origin pos))) (loop with previous-key-was-tab-p = nil - with keypress-condition = (when *readline-signal-keypresses* - (make-condition 'readline-keypress)) and displayed-completions-p = nil as key = (muerte:read-key console) do (with-saved-excursion (console) - (when keypress-condition - (setf (readline-keypress-key keypress-condition) key) + (when *readline-signal-keypresses* (with-simple-restart (continue "Proceed with interactive READLINE.") - (signal keypress-condition)))) + (signal 'readline-keypress :key key)))) (when (characterp key) (unless (char= key #\tab) (setf previous-key-was-tab-p nil))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 11 Mar '07

11 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14875 Modified Files: conditions.lisp Log Message: Have conditions be of metaclass read-only-class. --- /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2006/05/09 19:56:02 1.22 +++ /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2007/03/11 22:43:32 1.23 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.22 2006/05/09 19:56:02 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.23 2007/03/11 22:43:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,7 +28,7 @@ (defmacro define-condition (name parent-types slot-specs &rest options) `(progn - (defclass ,name ,(or parent-types '(condition)) ,slot-specs) + (defclass ,name ,(or parent-types '(condition)) ,slot-specs (:metaclass read-only-class)) ,@(let ((reporter (cadr (assoc :report options)))) (when reporter `((defmethod print-object ((condition ,name) stream)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 11 Mar '07

11 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14774 Modified Files: los-closette.lisp Log Message: Add metaclass read-only-class. --- /project/movitz/cvsroot/movitz/losp/muerte/los-closette.lisp 2006/04/10 11:52:21 1.36 +++ /project/movitz/cvsroot/movitz/losp/muerte/los-closette.lisp 2007/03/11 22:43:14 1.37 @@ -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.36 2006/04/10 11:52:21 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.37 2007/03/11 22:43:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -154,8 +154,7 @@ (defun std-gf-instance-class (instance) (check-type instance standard-gf-instance) - (memref instance (movitz-type-slot-offset 'movitz-funobj-standard-gf 'standard-gf-class)) - #+ignore (movitz-accessor instance movitz-funobj-standard-gf standard-gf-class)) + (memref instance (movitz-type-slot-offset 'movitz-funobj-standard-gf 'standard-gf-class))) (defun std-gf-instance-slots (instance) (check-type instance standard-gf-instance) @@ -198,8 +197,6 @@ (setf (memref funcallable-instance (movitz-type-slot-offset 'movitz-funobj-standard-gf 'standard-gf-function)) function) -;;; (setf-movitz-accessor (funcallable-instance movitz-funobj-standard-gf standard-gf-function) -;;; function) (values)) (defun funcallable-instance-function (funcallable-instance) @@ -1679,7 +1676,10 @@ (defmethod print-object ((object class) stream) (print-unreadable-object (object stream :identity nil :type t) - (write (class-name object) :stream stream)) + (write (if (slot-boundp object 'name) + (class-name object) + "[unnamed]") + :stream stream)) object) (defmethod print-object ((object standard-object) stream) @@ -1799,32 +1799,40 @@ (real-gf-mc #'generic-function-method-combination) (real-amsd #'accessor-method-slot-definition)) (with-alternative-fdefinitions - ((slow-method-lookup #'bootstrap-slow-method-lookup) + ((slow-method-lookup + #'bootstrap-slow-method-lookup) (slot-definition-name - (lambda (slot) (bootstrap-slot-definition-access slot 'name))) + (lambda (slot) + (bootstrap-slot-definition-access slot 'name))) (slot-definition-location - (lambda (slot) (bootstrap-slot-definition-access slot 'location))) + (lambda (slot) + (bootstrap-slot-definition-access slot 'location))) (class-slots - (lambda (class) (bootstrap-slot-definition-access class 'effective-slots))) + (lambda (class) + (bootstrap-slot-definition-access class 'effective-slots))) (class-precedence-list (lambda (class) (std-slot-value class 'class-precedence-list))) (method-specializers - (lambda (m) (std-slot-value m 'specializers))) + (lambda (m) + (std-slot-value m 'specializers))) (method-qualifiers - (lambda (m) (std-slot-value m 'qualifiers))) + (lambda (m) + (std-slot-value m 'qualifiers))) (method-function - (lambda (m) (std-slot-value m 'function))) + (lambda (m) + (std-slot-value m 'function))) (generic-function-methods - (lambda (gf) (std-gf-slot-value gf 'methods))) + (lambda (gf) + (std-gf-slot-value gf 'methods))) (generic-function-method-combination - (lambda (gf) (declare (ignore gf)) nil)) + (lambda (gf) + (declare (ignore gf)) nil)) (accessor-method-slot-definition (lambda (method) (std-slot-value method 'slot-definition))) (compute-applicable-methods-using-classes (lambda (gf classes) - ;; (warn "camuc of: ~S" (funobj-name gf)) (with-alternative-fdefinitions ((method-function (lambda (method) @@ -1898,4 +1906,28 @@ (setf (get 'clos-bootstrap 'have-bootstrapped) t) (values)))) +;;; + +(defclass read-only-class (standard-class) + ((instances + :initform (make-hash-table :test 'equal) + :reader read-only-class-instances + ))) + +(defmethod (setf slot-value-using-class) (new-value (class read-only-class) object slot) + (when (slot-boundp-using-class class object slot) + (cerror "Set the slot ~S of read-only object ~S to ~S anyway." + "Trying to set the slot ~S of read-only object ~S to ~S." + (slot-definition-name slot) object new-value)) + (call-next-method)) + +(defmethod make-instance ((class read-only-class) &rest initargs) + (declare (dynamic-extent initargs)) + (let ((defaulted-initargs (compute-defaulted-initargs class initargs))) + (or (gethash defaulted-initargs (read-only-class-instances class)) + (setf (gethash (copy-list defaulted-initargs) + (read-only-class-instances class)) + (apply 'initialize-instance + (apply 'allocate-instance class defaulted-initargs) + defaulted-initargs)))))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 11 Mar '07

11 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14757 Modified Files: los-closette-compiler.lisp Log Message: Add metaclass read-only-class. --- /project/movitz/cvsroot/movitz/losp/muerte/los-closette-compiler.lisp 2005/08/24 07:31:47 1.19 +++ /project/movitz/cvsroot/movitz/losp/muerte/los-closette-compiler.lisp 2007/03/11 22:43:10 1.20 @@ -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.19 2005/08/24 07:31:47 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.20 2007/03/11 22:43:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -551,6 +551,7 @@ direct-slots direct-superclasses &allow-other-keys) (declare (dynamic-extent all-keys)) + (remf all-keys :metaclass) (let ((old-class (movitz-find-class name nil))) (if (and old-class (eq metaclass *the-class-standard-class*)) @@ -568,6 +569,9 @@ 'movitz-make-instance) ((eq metaclass (movitz-find-class 'run-time-context-class nil)) 'movitz-make-instance) + ((member *the-class-standard-class* + (class-precedence-list metaclass)) + 'make-instance-standard-class) (t (break "Unknown metaclass: ~S" metaclass) #+ignore 'make-instance-built-in-class 'movitz-make-instance)) @@ -676,7 +680,7 @@ default-initargs-function documentation) (declare (ignore metaclass documentation)) - (let ((class (std-allocate-instance *the-class-standard-class*))) + (let ((class (std-allocate-instance metaclass))) (setf (movitz-class-name class) name) (setf (class-direct-subclasses class) ()) (setf (class-direct-methods class) ()) @@ -684,6 +688,16 @@ (setf (movitz-slot-value class 'plist) (when default-initargs-function (list :default-initargs-function default-initargs-function))) + (dolist (slot (class-slots (movitz-class-of class))) + (let ((slot-name (slot-definition-name slot)) + (slot-initform (muerte::translate-program (slot-definition-initform slot) + '#:muerte.cl '#:cl))) + (when slot-initform + (warn "init slot: ~S: ~S => ~S" + slot-name + slot-initform + (movitz::eval-form slot-initform)) + (setf (movitz-slot-value class slot-name) (movitz::eval-form slot-initform))))) (std-after-initialization-for-classes class :direct-slots direct-slots :direct-superclasses direct-superclasses) @@ -708,8 +722,10 @@ (dolist (writer (slot-definition-writers direct-slot)) (add-writer-method class writer (slot-definition-name direct-slot))))) - (funcall (if (or (eq (movitz-class-of class) *the-class-standard-class*) - (subclassp (movitz-class-of class) (movitz-find-class 'std-slotted-class))) + (funcall (if (or (eq (movitz-class-of class) + *the-class-standard-class*) + (subclassp (movitz-class-of class) + (movitz-find-class 'std-slotted-class))) #'std-finalize-inheritance #'finalize-inheritance) class)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 11 Mar '07

11 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14594 Modified Files: error.lisp Log Message: Added cerror. --- /project/movitz/cvsroot/movitz/losp/muerte/error.lisp 2007/02/06 20:02:01 1.5 +++ /project/movitz/cvsroot/movitz/losp/muerte/error.lisp 2007/03/11 22:42:01 1.6 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Sep 1 00:49:11 2001 ;;;; -;;;; $Id: error.lisp,v 1.5 2007/02/06 20:02:01 ffjeld Exp $ +;;;; $Id: error.lisp,v 1.6 2007/03/11 22:42:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -59,3 +59,9 @@ (defun formatted-error (type format-control &rest format-arguments) (declare (dynamic-extent format-arguments)) (error type :format-control format-control :format-arguments format-arguments)) + +(defun cerror (continue-format-control datum &rest arguments) + (declare (dynamic-extent arguments)) + (with-simple-restart (continue "~?" continue-format-control arguments) + (apply 'error datum arguments)) + nil)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 11 Mar '07

11 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14521 Modified Files: arrays.lisp Log Message: Insignificant syntax tweak. --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/02/22 21:02:09 1.60 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/03/11 22:41:45 1.61 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.60 2007/02/22 21:02:09 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.61 2007/03/11 22:41:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -564,8 +564,7 @@ (:jne 'not-basic-simple-vector) (:cmpl :edx (:ebx (:offset movitz-basic-vector num-elements))) (:jbe 'illegal-index) - (:movl :eax - (:ebx :edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))))) + (:movl :eax (:ebx :edx (:offset movitz-basic-vector data)))))) (do-it))) ;;; string accessors

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