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

[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

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

11 Mar '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv14273 Modified Files: compiler.lisp Log Message: Tweak peephole optimizer. --- /project/movitz/cvsroot/movitz/compiler.lisp 2007/03/01 21:27:39 1.181 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2007/03/11 22:40:57 1.182 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.181 2007/03/01 21:27:39 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.182 2007/03/11 22:40:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1288,22 +1288,25 @@ until (eq form '#0#) appending (with-simple-restart (skip-toplevel-form - "Skip the compilation of top-level form~@[ ~A~]." - (cond - ((symbolp form) form) - ((symbolp (car form)) (car form)))) + "Skip the compilation of top-level form~{ ~A~}." + (cond + ((symbolp form) + (list form)) + ((symbolp (car form)) + (list (car form) + (cadr form))))) (when *compiler-verbose-p* - (format *query-io* "~&Movitz Compiling ~S..~%" - (cond - ((symbolp form) form) - ((symbolp (car form)) - (xsubseq form 0 2))))) - (compiler-call #'compile-form - :form form - :funobj funobj - :env function-env - :top-level-p t - :result-mode :ignore)))))) + (format *query-io* "~&Movitz Compiling ~S..~%" + (cond + ((symbolp form) form) + ((symbolp (car form)) + (xsubseq form 0 2))))) + (compiler-call #'compile-form + :form form + :funobj funobj + :env function-env + :top-level-p t + :result-mode :ignore)))))) (cond ((null file-code) (setf (image-load-time-funobjs *image*) @@ -1819,49 +1822,55 @@ until (eq i 'start-stack-frame-setup)) (assert (eq (car new-code) 'start-stack-frame-setup) () "no start-stack-frame-setup label, but we already checked!") - (let* ((frame-map (loop for pos downfrom -8 by 4 + (let* ((frame-map (loop with pos = -8 as i = (pop old-code) - if (and (consp i) (eq :pushl (car i)) (symbolp (cadr i))) - collect (cons pos (cadr i)) - and do (push i new-code) + if (instruction-is i :frame-map) + do (progn :nothing) + else if + (and (consp i) (eq :pushl (car i)) (symbolp (cadr i))) + collect + (cons pos (cadr i)) + and do + (decf pos 4) + (push i new-code) else do - (push i old-code) - (loop-finish))) + (push i old-code) + (loop-finish))) (mod-p (loop with mod-p = nil for i = `(:frame-map ,(copy-list frame-map) nil t) then (pop old-code) while i - do (let ((new-i (cond - ((let ((store-pos (store-stack-frame-p i))) - (and store-pos - (eq (cdr (assoc store-pos frame-map)) - (twop-src i)))) - (explain nil "removed stack-init store: ~S" i) - nil) - ((let ((load-pos (load-stack-frame-p i))) - (and load-pos - (eq (cdr (assoc load-pos frame-map)) - (twop-dst i)))) - (explain nil "removed stack-init load: ~S" i) - nil) - ((and (load-stack-frame-p i) - (assoc (load-stack-frame-p i) frame-map)) - (let ((old-reg (cdr (assoc (load-stack-frame-p i) - frame-map)))) - (explain nil "load ~S already in ~S." - i old-reg) - `(:movl ,old-reg ,(twop-dst i)))) - ((and (instruction-is i :pushl) - (stack-frame-operand (idst i)) - (assoc (stack-frame-operand (idst i)) - frame-map)) - (let ((old-reg - (cdr (assoc (stack-frame-operand (idst i)) - frame-map)))) - (explain nil "push ~S already in ~S." - i old-reg) - `(:pushl ,old-reg))) - (t i)))) + do (let ((new-i (cond + ((let ((store-pos (store-stack-frame-p i))) + (and store-pos + (eq (cdr (assoc store-pos frame-map)) + (twop-src i)))) + (explain nil "removed stack-init store: ~S" i) + nil) + ((let ((load-pos (load-stack-frame-p i))) + (and load-pos + (eq (cdr (assoc load-pos frame-map)) + (twop-dst i)))) + (explain nil "removed stack-init load: ~S" i) + nil) + ((and (load-stack-frame-p i) + (assoc (load-stack-frame-p i) frame-map)) + (let ((old-reg (cdr (assoc (load-stack-frame-p i) + frame-map)))) + (explain nil "load ~S already in ~S." + i old-reg) + `(:movl ,old-reg ,(twop-dst i)))) + ((and (instruction-is i :pushl) + (stack-frame-operand (idst i)) + (assoc (stack-frame-operand (idst i)) + frame-map)) + (let ((old-reg + (cdr (assoc (stack-frame-operand (idst i)) + frame-map)))) + (explain nil "push ~S already in ~S." + i old-reg) + `(:pushl ,old-reg))) + (t i)))) (unless (eq new-i i) (setf mod-p t)) (when (branch-instruction-label new-i t) @@ -1872,12 +1881,12 @@ (push new-i new-code) ;; (warn "new-i: ~S, fm: ~S" new-i frame-map) (setf frame-map - (delete-if (lambda (map) - ;; (warn "considering: ~S" map) - (not (and (preserves-register-p new-i (cdr map)) - (preserves-stack-location-p new-i - (car map))))) - frame-map)) + (delete-if (lambda (map) + ;; (warn "considering: ~S" map) + (not (and (preserves-register-p new-i (cdr map)) + (preserves-stack-location-p new-i + (car map))))) + frame-map)) ;; (warn "Frame-map now: ~S" frame-map) (when (store-stack-frame-p new-i) (loop for map in frame-map @@ -1889,7 +1898,11 @@ (if (not mod-p) unoptimized-code (append (nreverse new-code) - old-code))))))) + old-code)))))) + (remove-frame-maps (code) + (remove-if (lambda (x) + (typep x '(cons (eql :frame-map) *))) + code))) (let* ((unoptimized-code (frame-map-code (optimize-stack-frame-init unoptimized-code))) (code-modified-p nil) (stack-frame-used-map (loop with map = nil @@ -2282,13 +2295,7 @@ nconc p))) (if code-modified-p (apply #'optimize-code-internal optimized-code (1+ recursive-count) key-args) - (optimize-trim-stack-frame - (remove :frame-map (progn #+ignore (warn "maps:~{~&~A~}" unoptimized-code) - unoptimized-code) - :key (lambda (x) - (when (consp x) - (car x)))))))))) - + (optimize-trim-stack-frame (remove-frame-maps unoptimized-code))))))) ;;;; Compiler internals (defclass binding ()

1 0

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

11 Mar '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv13222 Modified Files: bootblock.lisp Log Message: Support weird floppy geometries (because of Qemu). --- /project/movitz/cvsroot/movitz/bootblock.lisp 2005/02/02 07:48:21 1.11 +++ /project/movitz/cvsroot/movitz/bootblock.lisp 2007/03/11 22:40:16 1.12 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Oct 9 20:47:19 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: bootblock.lisp,v 1.11 2005/02/02 07:48:21 ffjeld Exp $ +;;;; $Id: bootblock.lisp,v 1.12 2007/03/11 22:40:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -73,7 +73,8 @@ (defconstant +linear-sector+ -4) (defconstant +destination+ -8) -(defconstant +stack-frame-size+ 12) +(defconstant +sectors-per-track+ -12) +(defconstant +stack-frame-size+ 16) (defconstant +read-buffer+ #x10000) @@ -114,6 +115,23 @@ (:outb :al #x60) (:call 'empty-8042) + ;; Poll the floppy's sectors per track + + (:movw 5 (:bp ,+sectors-per-track+)) + check-geometry + (:incb (:bp ,+sectors-per-track+)) + (:jz 'read-error) + (:movw (:bp ,+sectors-per-track+) :cx ) + (:movw #x0201 :ax) + (:xorw :dx :dx) + (:movw ,read-buffer-segment :bx) + (:movw :bx :es) + (:xorw :bx :bx) + (:int #x13) ; Call BIOS routine + (:testb :ah :ah) + (:jz 'check-geometry) + (:decb (:bp ,+sectors-per-track+)) + ;; ;; Read sectors into memory ;; @@ -130,16 +148,16 @@ (:call 'print) (:movw (:bp ,+linear-sector+) :ax) - (:movb 18 :cl) + (:movb (:bp ,+sectors-per-track+) :cl) (:divb :cl :ax) ; al=quotient, ah=remainder of :ax/:cl - + (:movb :ah :cl) ; sector - 1 (:movb :al :dh) (:andb 1 :dh) ; head (:movb :al :ch) (:shrb 1 :ch) ; track (:xorb :dl :dl) ; drive = 0 - (:movw 18 :ax) + (:movw (:bp ,+sectors-per-track+) :ax) (:subb :cl :al) ; number of sectors (rest of track) (:incb :cl) (:addw :ax (:bp ,+linear-sector+)) ; update read pointer @@ -154,14 +172,14 @@ (:movw ,read-buffer-segment :bx) (:movw :bx :es) (:xorw :bx :bx) - (:int #x13) ; Call BIOS routine + (:jc 'read-error) (:movzxb :al :ecx) ;; ;; Install GS as 4GB segment - ;; http://www2.dgsys.com/~raymoon/faq/gen2.html#15 + ;; http://www.faqs.org/faqs/assembly-language/x86/general/part2/ ;; (:cli) (:lgdt ('gdt-addr)) ; load gdt @@ -178,10 +196,11 @@ ;; Completed install GS as 4GB segment. ;; Copy data to destination - (:shll ,(+ 9 -2) :ecx) + (:shll ,(+ 9 -2) :ecx) ; 512/4 = sector-size/word-size (:movl ,+read-buffer+ :ebx) (:movl (:bp ,+destination+) :esi) (:leal (:esi (:ecx 4)) :edx) + (:movl :edx (:bp ,+destination+)) copy-loop @@ -189,14 +208,14 @@ ((:gs-override) :movl (:ebx (:ecx 4)) :edx) ((:gs-override) :movl :edx (:esi (:ecx 4))) (:jnz 'copy-loop) - + (:movw 'track-end-msg :si) ; Print ')' to screen after each track (:call 'print) (:jmp 'read-loop) read-done - + motor-loop ; Wait for floppy motor (:btw 8 (#x43e)) (:jc 'motor-loop) @@ -269,9 +288,8 @@ (:ret) delay - (:movw 500 :cx) + (:xorw :cx :cx) delay-loop - (:nop) (:loop 'delay-loop) (:ret)

1 0