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

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

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv31071 Modified Files: scavenge.lisp Log Message: Improved format-strings in map-header-vals. --- /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2007/04/05 21:12:19 1.60 +++ /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2007/04/07 20:50:38 1.61 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.60 2007/04/05 21:12:19 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.61 2007/04/07 20:50:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -67,7 +67,7 @@ (let ((x (memref scan 0 :type :unsigned-byte16)) (x2 (memref scan 2 :type :unsigned-byte16))) (when verbose - (format *terminal-io* " [at ~S: ~S]" scan x)) + (format *terminal-io* " [at #x~X: #x~X]" scan x)) (cond ((let ((tag (ldb (byte 3 0) x))) (or (= tag #.(movitz:tag :null)) @@ -78,10 +78,10 @@ (and (= #xffff x2) (= #xfffe x)) (and (= #x7fff x2) (= #xffff x)))) ((scavenge-typep x :illegal) - (error "Illegal word ~S at ~S." x scan)) + (error "Illegal word #x~4,'0X at #x~X." x scan)) ((scavenge-typep x :bignum) (assert (evenp scan) () - "Scanned bignum-header ~S at odd location #x~X." x scan) + "Scanned bignum-header #x~4,'0X at odd location #x~X." x scan) ;; Just skip the bigits (let* ((bigits (memref scan 0 :index 1 :type :unsigned-byte14)) (delta (logior bigits 1))) @@ -89,11 +89,11 @@ (incf scan delta))) ((scavenge-typep x :defstruct) (assert (evenp scan) () - "Scanned struct-header ~S at odd location #x~X." x scan) + "Scanned struct-header #x~4,'0X at odd location #x~X." x scan) (record-scan (%word-offset scan #.(movitz:tag :other)))) ((scavenge-typep x :run-time-context) (assert (evenp scan) () - "Scanned run-time-context-header ~S at odd location #x~X." + "Scanned run-time-context-header #x~4,'0X at odd location #x~X." (memref scan 0 :type :unsigned-byte32) scan) (incf scan) (let ((non-lispvals #.(cl:truncate (cl:+ -4 (bt:slot-offset 'movitz::movitz-run-time-context @@ -106,7 +106,7 @@ (setf scan end))) ((scavenge-typep x :funobj) (assert (evenp scan) () - "Scanned funobj-header ~S at odd location #x~X." + "Scanned funobj-header #x~4,'0X at odd location #x~X." (memref scan 0 :type :unsigned-byte32) scan) (record-scan (%word-offset scan #.(movitz:tag :other))) ;; Process code-vector pointers specially.. @@ -157,11 +157,11 @@ (incf scan num-jumpers)))))) ((scavenge-typep x :infant-object) (assert (evenp scan) () - "Scanned infant ~S at odd location #x~X." x scan) - (error "Scanning an infant object ~Z at ~S (end ~S)." x scan end-location)) + "Scanned infant #x~4,'0X at odd location #x~X." x scan) + (error "Scanning an infant object #x~4,'0X at #x~X (end #x~X)." x scan end-location)) ((scavenge-typep x :basic-vector) (assert (evenp scan) () - "Scanned basic-vector-header ~S at odd location #x~X." x scan) + "Scanned basic-vector-header #x~4,'0X at odd location #x~X." x scan) (cond ((or (scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u8)) @@ -191,7 +191,7 @@ #.(bt:enum-value 'movitz:movitz-vector-element-type :indirects))) (record-scan (%word-offset scan #.(movitz:tag :other)))) - (t (error "Scanned unknown basic-vector-header ~S at location #x~X." x scan)))) + (t (error "Scanned unknown basic-vector-header #x~4,'0X at location #x~X." x scan)))) ((and (eq x 3) (eq x2 0)) (record-scan scan) (incf scan) @@ -202,9 +202,9 @@ (t ;; (typep x 'pointer) (let* ((old (memref scan 0)) (new (funcall function old scan))) - (when verbose - (format *terminal-io* " [~Z => ~Z]" old new)) (unless (eq old new) + (when verbose + (format *terminal-io* " [~Z => ~Z]" old new)) (setf (memref scan 0) new)))))))) (values))

1 0

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

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv30506 Modified Files: interrupt.lisp Log Message: Improved error decoding for exception 69. --- /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2007/03/26 21:11:43 1.55 +++ /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2007/04/07 20:49:17 1.56 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.55 2007/03/26 21:11:43 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.56 2007/04/07 20:49:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -342,10 +342,15 @@ $eip $eax $ebx $ecx $edx) (dotimes (i 100000) (with-inline-assembly (:returns :nothing) (:nop)))) - (69 (error 'type-error - :datum (dereference $eax) - :expected-type (aref #(cons function) - (dereference $ecx :unsigned-byte8)))) + (69 (let ((expected-type + (aref #(cons function) + (dereference $ecx :unsigned-byte8)))) + (error 'type-error + :datum (case expected-type + (function + (dereference $edx)) + (t (dereference $eax))) + :expected-type expected-type))) (70 (error "Unaligned memref access.")) ((5 55) (let* ((old-bottom (prog1 (%run-time-context-slot nil 'stack-bottom)

1 0

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

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv25962 Modified Files: arrays.lisp Log Message: make-basic-vector%t used to have an atomic-sequence that was O(N) to the length of the vector. Consequently, with somewhat frequent interrupts and a slightly large N, this sequence would never reach completion. Lesson is, atomic sequences must be O(1). --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/03/11 22:41:45 1.61 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/04/07 20:18:20 1.62 @@ -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.61 2007/03/11 22:41:45 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.62 2007/04/07 20:18:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1040,36 +1040,75 @@ (defun make-basic-vector%t (length fill-pointer initial-element initial-contents) (check-type length (and fixnum (integer 0 *))) - (let* ((words (+ 2 length)) - (array (macrolet - ((do-it () - `(with-allocation-assembly (words :fixed-size-p t - :object-register :eax) - (:load-lexical (:lexical-binding length) :ecx) - (:movl ,(movitz:basic-vector-type-tag :any-t) - (:eax (:offset movitz-basic-vector type))) - (:movl :ecx (:eax (:offset movitz-basic-vector num-elements))) - (:addl 4 :ecx) - (:andl -8 :ecx) - (:jz 'init-done) - (:load-lexical (:lexical-binding initial-element) :edx) - init-loop - (:movl :edx (:eax (:offset movitz-basic-vector data) :ecx -4)) - (:subl 4 :ecx) - (:jnz 'init-loop) - init-done - ))) - (do-it)))) + (let* ((words (+ 2 length))) (cond - ((integerp fill-pointer) - (setf (fill-pointer array) fill-pointer)) - ((or (eq t fill-pointer) - (array-has-fill-pointer-p array)) - (setf (fill-pointer array) length))) - (cond - (initial-contents - (replace array initial-contents))) - array)) + ((<= length 8) + (let ((array (macrolet + ((do-it () + `(with-allocation-assembly (words :fixed-size-p t + :object-register :eax) + (:load-lexical (:lexical-binding length) :ecx) + (:movl ,(movitz:basic-vector-type-tag :any-t) + (:eax (:offset movitz-basic-vector type))) + (:movl :ecx (:eax (:offset movitz-basic-vector num-elements))) + (:addl 4 :ecx) + (:andl -8 :ecx) + (:jz 'init-done) + (:load-lexical (:lexical-binding initial-element) :edx) + init-loop + (:movl :edx (:eax (:offset movitz-basic-vector data) :ecx -4)) + (:subl 4 :ecx) + (:jnz 'init-loop) + init-done + ))) + (do-it)))) + (cond + ((integerp fill-pointer) + (setf (fill-pointer array) fill-pointer)) + ((or (eq t fill-pointer) + (array-has-fill-pointer-p array)) + (setf (fill-pointer array) length))) + (when initial-contents + (replace array initial-contents)) + array)) + (t (let* ((init-word (if (typep initial-element '(or null fixnum character)) + initial-element + nil)) + (array (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) + (with-non-pointer-allocation-assembly (words :fixed-size-p t + :object-register :eax) + (:load-lexical (:lexical-binding length) :ecx) + (:movl ,(movitz:basic-vector-type-tag :u32) + (:eax (:offset movitz-basic-vector type))) + (:movl :ecx (:eax (:offset movitz-basic-vector num-elements))))) + (:load-lexical (:lexical-binding length) :ecx) + (:addl 4 :ecx) + (:andl -8 :ecx) + (:jz 'init-done2) + (:load-lexical (:lexical-binding init-word) :edx) + init-loop2 + (:movl :edx (:eax (:offset movitz-basic-vector data) :ecx -4)) + (:subl 4 :ecx) + (:jnz 'init-loop2) + init-done2 + (:movl ,(movitz:basic-vector-type-tag :any-t) + (:eax (:offset movitz-basic-vector type)))))) + (do-it)))) + (cond + ((integerp fill-pointer) + (setf (fill-pointer array) fill-pointer)) + ((or (eq t fill-pointer) + (array-has-fill-pointer-p array)) + (setf (fill-pointer array) length))) + (cond + (initial-contents + (replace array initial-contents)) + ((not (eq init-word initial-element)) + (fill array initial-element))) + array))))) (defun make-indirect-vector (displaced-to displaced-offset fill-pointer length) (let ((x (make-basic-vector%t 4 0 nil nil)))

1 0

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

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv25634 Modified Files: sequences.lisp Log Message: Fix nsubstitute-if for :from-end t. Previously it could spin eternally. --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2007/04/07 07:59:31 1.36 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2007/04/07 20:14:45 1.37 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.36 2007/04/07 07:59:31 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.37 2007/04/07 20:14:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1886,90 +1886,97 @@ (defun nsubstitute-if (newitem predicate sequence &key (start 0) end count (key 'identity) from-end) "=> sequence" - (with-funcallable (predicate) - (with-funcallable (key) - (sequence-dispatch sequence - (vector - (let ((end (or end (length sequence)))) - (with-subvector-accessor (ref sequence start end) - (cond - ((and (not count) (not from-end)) - (do ((i start (1+ i))) - ((>= i end) sequence) - (declare (index i)) - (when (predicate (key (ref i))) - (setf (ref i) newitem)))) - ((and count (not from-end)) - (do ((c 0) - (i start (1+ i))) - ((>= i end) sequence) - (declare (index i c)) - (when (predicate (key (ref i))) - (setf (ref i) newitem) - (when (>= (incf c) count) - (return sequence))))) - ((and (not count) from-end) - (do ((i (1- end) (1- i))) - ((< i start) sequence) - (declare (index i)) - (when (predicate (key (ref i))) - (setf (ref i) newitem)))) - ((and count from-end) - (do ((c 0) - (i (1- end) (1- i))) - ((< i start) sequence) - (declare (index c i)) - (when (predicate (key (ref i))) - (setf (ref i) newitem) - (when (>= (incf c) count) - (return sequence))))) - ((error 'program-error)))))) - (list - (let ((p (nthcdr start sequence))) - (if (and from-end count) - (let* ((end (and end (- end start))) - (existing-count (count-if predicate p :key key :end end))) - (do ((i count)) - ((>= i existing-count) - (nsubstitute-if newitem predicate p :end end :key key) - sequence) - (declare (index i)) - (when (predicate (key (car p))) - (incf i)) - (setf p (cdr p)))) - (cond - ((and (not end) (not count)) - (do ((p p (cdr p))) - ((endp p) sequence) - (when (predicate (key (car p))) - (setf (car p) newitem)))) - ((and end (not count)) - (do ((i start (1+ i)) - (p p (cdr p))) - ((or (endp p) (>= i end)) sequence) - (declare (index i)) - (when (predicate (key (car p))) - (setf (car p) newitem)))) - ((and (not end) count) - (do ((c 0) - (p p (cdr p))) - ((endp p) sequence) - (declare (index c)) - (when (predicate (key (car p))) - (setf (car p) newitem) - (when (>= (incf c) count) - (return sequence))))) - ((and end count) - (do ((c 0) - (i start (1+ i)) - (p p (cdr p))) - ((or (endp p) (>= i end)) sequence) - (declare (index c i)) - (when (predicate (key (car p))) - (setf (car p) newitem) - (when (>= (incf c) count) - (return sequence))))) - ((error 'program-error)))))))))) + (if (<= count 0) + sequence + (with-funcallable (predicate) + (with-funcallable (key) + (sequence-dispatch sequence + (vector + (let ((end (or end (length sequence)))) + (with-subvector-accessor (ref sequence start end) + (cond + ((and (not count) (not from-end)) + (do ((i start (1+ i))) + ((>= i end) sequence) + (declare (index i)) + (when (predicate (key (ref i))) + (setf (ref i) newitem)))) + ((and count (not from-end)) + (do ((c 0) + (i start (1+ i))) + ((>= i end) sequence) + (declare (index i c)) + (when (predicate (key (ref i))) + (setf (ref i) newitem) + (when (>= (incf c) count) + (return sequence))))) + ((and (not count) from-end) + (do ((i (1- end) (1- i))) + ((< i start) sequence) + (declare (index i)) + (when (predicate (key (ref i))) + (setf (ref i) newitem)))) + ((and count from-end) + (do ((c 0) + (i (1- end) (1- i))) + ((< i start) sequence) + (declare (index c i)) + (when (predicate (key (ref i))) + (setf (ref i) newitem) + (when (>= (incf c) count) + (return sequence))))) + ((error 'program-error)))))) + (list + (let ((p (nthcdr start sequence))) + (cond + (from-end + (nreverse (nsubstitute-if newitem predicate (nreverse sequence) + :start (if (not end) 0 (- (length sequence) end)) + :end (if (plusp start) nil (- (length sequence) start)) + :count count :key key))) + #+ignore ((and from-end count) + (let* ((end (and end (- end start))) + (existing-count (count-if predicate p :key key :end end))) + (do ((i count)) + ((>= i existing-count) + (nsubstitute-if newitem predicate p :end end :key key) + sequence) + (declare (index i)) + (when (predicate (key (car p))) + (incf i)) + (setf p (cdr p))))) + ((and (not end) (not count)) + (do ((p p (cdr p))) + ((endp p) sequence) + (when (predicate (key (car p))) + (setf (car p) newitem)))) + ((and end (not count)) + (do ((i start (1+ i)) + (p p (cdr p))) + ((or (endp p) (>= i end)) sequence) + (declare (index i)) + (when (predicate (key (car p))) + (setf (car p) newitem)))) + ((and (not end) count) + (do ((c 0) + (p p (cdr p))) + ((endp p) sequence) + (declare (index c)) + (when (predicate (key (car p))) + (setf (car p) newitem) + (when (>= (incf c) count) + (return sequence))))) + ((and end count) + (do ((c 0) + (i start (1+ i)) + (p p (cdr p))) + ((or (endp p) (>= i end)) sequence) + (declare (index c i)) + (when (predicate (key (car p))) + (setf (car p) newitem) + (when (>= (incf c) count) + (return sequence))))) + ((error 'program-error)))))))))) (defun nsubstitute-if-not (newitem predicate sequence &rest keyargs) (declare (dynamic-extent keyargs))

1 0

[movitz-cvs] CVS movitz/losp/x86-pc
by ffjeld 07 Apr '07

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory clnet:/tmp/cvs-serv26637 Modified Files: vga.lisp Log Message: Indentation. --- /project/movitz/cvsroot/movitz/losp/x86-pc/vga.lisp 2007/03/26 18:04:04 1.12 +++ /project/movitz/cvsroot/movitz/losp/x86-pc/vga.lisp 2007/04/07 08:04:51 1.13 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 25 14:08:20 2001 ;;;; -;;;; $Id: vga.lisp,v 1.12 2007/03/26 18:04:04 ffjeld Exp $ +;;;; $Id: vga.lisp,v 1.13 2007/04/07 08:04:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -106,131 +106,131 @@ ;;; VGA stuff ported from http://my.execpc.com/CE/AC/geezer/osd/graphics/modes.c (defconstant +vga-state-80x25+ - '((:misc . #x67) - (:sequencer - #x03 #x00 #x03 #x00 #x02) - (:crtc - #x5F #x4F #x50 #x82 #x55 #x81 #xBF #x1F - #x00 #x4F #x0D #x0E #x00 #x00 #x00 #x50 - #x9C #x0E #x8F #x28 #x1F #x96 #xB9 #xA3 - #xFF) - (:graphics - #x00 #x00 #x00 #x00 #x00 #x10 #x0E #x00 - #xFF) - (:attribute - #x00 #x01 #x02 #x03 #x04 #x05 #x14 #x07 - #x38 #x39 #x3A #x3B #x3C #x3D #x3E #x3F - #x0C #x00 #x0F #x08 #x00))) + '((:misc . #x67) + (:sequencer + #x03 #x00 #x03 #x00 #x02) + (:crtc + #x5F #x4F #x50 #x82 #x55 #x81 #xBF #x1F + #x00 #x4F #x0D #x0E #x00 #x00 #x00 #x50 + #x9C #x0E #x8F #x28 #x1F #x96 #xB9 #xA3 + #xFF) + (:graphics + #x00 #x00 #x00 #x00 #x00 #x10 #x0E #x00 + #xFF) + (:attribute + #x00 #x01 #x02 #x03 #x04 #x05 #x14 #x07 + #x38 #x39 #x3A #x3B #x3C #x3D #x3E #x3F + #x0C #x00 #x0F #x08 #x00))) (defconstant +vga-state-80x50+ - '((:misc . #x67) - (:sequencer - #x03 #x00 #x03 #x00 #x02) - (:crtc - #x5F #x4F #x50 #x82 #x55 #x81 #xBF #x1F - #x00 #x47 #x06 #x07 #x00 #x00 #x01 #x40 - #x9C #x8E #x8F #x28 #x1F #x96 #xB9 #xA3 - #xFF) - (:graphics - #x00 #x00 #x00 #x00 #x00 #x10 #x0E #x00 - #xFF) - (:attribute - #x00 #x01 #x02 #x03 #x04 #x05 #x14 #x07 - #x38 #x39 #x3A #x3B #x3C #x3D #x3E #x3F - #x0C #x00 #x0F #x08 #x00))) + '((:misc . #x67) + (:sequencer + #x03 #x00 #x03 #x00 #x02) + (:crtc + #x5F #x4F #x50 #x82 #x55 #x81 #xBF #x1F + #x00 #x47 #x06 #x07 #x00 #x00 #x01 #x40 + #x9C #x8E #x8F #x28 #x1F #x96 #xB9 #xA3 + #xFF) + (:graphics + #x00 #x00 #x00 #x00 #x00 #x10 #x0E #x00 + #xFF) + (:attribute + #x00 #x01 #x02 #x03 #x04 #x05 #x14 #x07 + #x38 #x39 #x3A #x3B #x3C #x3D #x3E #x3F + #x0C #x00 #x0F #x08 #x00))) (defconstant +vga-state-40x25+ - '((:misc . #x67) - (:sequencer - #x03 #x08 #x03 #x00 #x02) - (:crtc - #x2D #x27 #x28 #x90 #x2B #xA0 #xBF #x1F - #x00 #x4F #x0D #x0E #x00 #x00 #x00 #xA0 - #x9C #x8E #x8F #x14 #x1F #x96 #xB9 #xA3 - #xFF) - (:graphics - #x00 #x00 #x00 #x00 #x00 #x10 #x0E #x00 - #xFF) - (:attribute - #x00 #x01 #x02 #x03 #x04 #x05 #x14 #x07 - #x38 #x39 #x3A #x3B #x3C #x3D #x3E #x3F - #x0C #x00 #x0F #x08 #x00))) + '((:misc . #x67) + (:sequencer + #x03 #x08 #x03 #x00 #x02) + (:crtc + #x2D #x27 #x28 #x90 #x2B #xA0 #xBF #x1F + #x00 #x4F #x0D #x0E #x00 #x00 #x00 #xA0 + #x9C #x8E #x8F #x14 #x1F #x96 #xB9 #xA3 + #xFF) + (:graphics + #x00 #x00 #x00 #x00 #x00 #x10 #x0E #x00 + #xFF) + (:attribute + #x00 #x01 #x02 #x03 #x04 #x05 #x14 #x07 + #x38 #x39 #x3A #x3B #x3C #x3D #x3E #x3F + #x0C #x00 #x0F #x08 #x00))) (defconstant +vga-state-40x50+ - '((:misc . #x67) - (:sequencer - #x03 #x08 #x03 #x00 #x02) - (:crtc - #x2D #x27 #x28 #x90 #x2B #xA0 #xBF #x1F - #x00 #x47 #x06 #x07 #x00 #x00 #x04 #x60 - #x9C #x8E #x8F #x14 #x1F #x96 #xB9 #xA3 - #xFF) - (:graphics - #x00 #x00 #x00 #x00 #x00 #x10 #x0E #x00 - #xFF) - (:attribute - #x00 #x01 #x02 #x03 #x04 #x05 #x14 #x07 - #x38 #x39 #x3A #x3B #x3C #x3D #x3E #x3F - #x0C #x00 #x0F #x08 #x00))) + '((:misc . #x67) + (:sequencer + #x03 #x08 #x03 #x00 #x02) + (:crtc + #x2D #x27 #x28 #x90 #x2B #xA0 #xBF #x1F + #x00 #x47 #x06 #x07 #x00 #x00 #x04 #x60 + #x9C #x8E #x8F #x14 #x1F #x96 #xB9 #xA3 + #xFF) + (:graphics + #x00 #x00 #x00 #x00 #x00 #x10 #x0E #x00 + #xFF) + (:attribute + #x00 #x01 #x02 #x03 #x04 #x05 #x14 #x07 + #x38 #x39 #x3A #x3B #x3C #x3D #x3E #x3F + #x0C #x00 #x0F #x08 #x00))) (defconstant +vga-state-90x30+ - '((:misc . #xE7) - (:sequencer - #x03 #x01 #x03 #x00 #x02) - (:crtc - #x6B #x59 #x5A #x82 #x60 #x8D #x0B #x3E - #x00 #x4F #x0D #x0E #x00 #x00 #x00 #x00 - #xEA #x0C #xDF #x2D #x10 #xE8 #x05 #xA3 - #xFF) - (:graphics - #x00 #x00 #x00 #x00 #x00 #x10 #x0E #x00 - #xFF) - (:attribute - #x00 #x01 #x02 #x03 #x04 #x05 #x14 #x07 - #x38 #x39 #x3A #x3B #x3C #x3D #x3E #x3F - #x0C #x00 #x0F #x08 #x00))) + '((:misc . #xE7) + (:sequencer + #x03 #x01 #x03 #x00 #x02) + (:crtc + #x6B #x59 #x5A #x82 #x60 #x8D #x0B #x3E + #x00 #x4F #x0D #x0E #x00 #x00 #x00 #x00 + #xEA #x0C #xDF #x2D #x10 #xE8 #x05 #xA3 + #xFF) + (:graphics + #x00 #x00 #x00 #x00 #x00 #x10 #x0E #x00 + #xFF) + (:attribute + #x00 #x01 #x02 #x03 #x04 #x05 #x14 #x07 + #x38 #x39 #x3A #x3B #x3C #x3D #x3E #x3F + #x0C #x00 #x0F #x08 #x00))) (defconstant +vga-state-90x60+ - '((:misc . #xE7) - (:sequencer - #x03 #x01 #x03 #x00 #x02) - (:crtc - #x6B #x59 #x5A #x82 #x60 #x8D #x0B #x3E - #x00 #x47 #x06 #x07 #x00 #x00 #x00 #x00 - #xEA #x0C #xDF #x2D #x08 #xE8 #x05 #xA3 - #xFF) - (:graphics - #x00 #x00 #x00 #x00 #x00 #x10 #x0E #x00 - #xFF) - (:attribute - #x00 #x01 #x02 #x03 #x04 #x05 #x14 #x07 - #x38 #x39 #x3A #x3B #x3C #x3D #x3E #x3F - #x0C #x00 #x0F #x08 #x00))) + '((:misc . #xE7) + (:sequencer + #x03 #x01 #x03 #x00 #x02) + (:crtc + #x6B #x59 #x5A #x82 #x60 #x8D #x0B #x3E + #x00 #x47 #x06 #x07 #x00 #x00 #x00 #x00 + #xEA #x0C #xDF #x2D #x08 #xE8 #x05 #xA3 + #xFF) + (:graphics + #x00 #x00 #x00 #x00 #x00 #x10 #x0E #x00 + #xFF) + (:attribute + #x00 #x01 #x02 #x03 #x04 #x05 #x14 #x07 + #x38 #x39 #x3A #x3B #x3C #x3D #x3E #x3F + #x0C #x00 #x0F #x08 #x00))) (defconstant +vga-state-320x200x256-modex+ - '((:misc . #x63) - (:sequencer - #x03 #x01 #x0F #x00 #x06) - (:crtc - #x5F #x4F #x50 #x82 #x54 #x80 #xBF #x1F - #x00 #x41 #x00 #x00 #x00 #x00 #x00 #x00 - #x9C #x0E #x8F #x28 #x00 #x96 #xB9 #xE3 - #xFF) - (:graphics - #x00 #x00 #x00 #x00 #x00 #x40 #x05 #x0F - #xFF) - (:attribute - #x00 #x01 #x02 #x03 #x04 #x05 #x06 #x07 - #x08 #x09 #x0A #x0B #x0C #x0D #x0E #x0F - #x41 #x00 #x0F #x00 #x00))) + '((:misc . #x63) + (:sequencer + #x03 #x01 #x0F #x00 #x06) + (:crtc + #x5F #x4F #x50 #x82 #x54 #x80 #xBF #x1F + #x00 #x41 #x00 #x00 #x00 #x00 #x00 #x00 + #x9C #x0E #x8F #x28 #x00 #x96 #xB9 #xE3 + #xFF) + (:graphics + #x00 #x00 #x00 #x00 #x00 #x40 #x05 #x0F + #xFF) + (:attribute + #x00 #x01 #x02 #x03 #x04 #x05 #x06 #x07 + #x08 #x09 #x0A #x0B #x0C #x0D #x0E #x0F + #x41 #x00 #x0F #x00 #x00))) ;; intended future wrapper for graphics modes (defconstant +graphical-mode-modex+ - '(+vga-state-320x200x256-modex+ ; vga state - 320 ; width - 200 ; height - 3)) ; page count + '(+vga-state-320x200x256-modex+ ; vga state + 320 ; width + 200 ; height + 3)) ; page count (defvar *vga-current-page* 0) @@ -294,40 +294,40 @@ (assert set () "VGA state is missing ~A." register-set) (cdr set)))) (unwind-protect - (handler-bind ((serious-condition #'vga-reset)) - ;; write MISCELLANEOUS reg - (setf (vga-port +vga-misc-write+) - (assert-register-set state :misc)) - ;; write SEQUENCER regs - (loop for x in (assert-register-set state :sequencer) - as i upfrom 0 - do (setf (vga-sequencer-register i) x)) - (loop - ;; unlock CRTC registers - initially (setf (vga-crt-controller-register 3) - (logior #x80 (vga-crt-controller-register 3))) - (setf (vga-crt-controller-register #x11) - (logand #x7f (vga-crt-controller-register #x11))) - for x in (assert-register-set state :crtc) - as i upfrom 0 - do (setf (vga-crt-controller-register i) - (case i - ;; make sure they remain unlocked - (#x03 (logior #x80 x)) - (#x11 (logand #x7f x)) - (t x)))) - ;; write GRAPHICS CONTROLLER regs - (loop for x in (assert-register-set state :graphics) - as i upfrom 0 - do (setf (vga-graphics-register i) x)) - ;; write ATTRIBUTE CONTROLLER regs - (loop for x in (assert-register-set state :attribute) - as i upfrom 0 - do (setf (vga-attribute-register i) x)) - ;; lock 16-color palette and unblank display - (io-port VGA-INSTAT-READ :unsigned-byte8) - (setf (io-port VGA-AC-INDEX :unsigned-byte8) #x20) - (setf old-state nil)) + (handler-bind ((serious-condition #'vga-reset)) + ;; write MISCELLANEOUS reg + (setf (vga-port +vga-misc-write+) + (assert-register-set state :misc)) + ;; write SEQUENCER regs + (loop for x in (assert-register-set state :sequencer) + as i upfrom 0 + do (setf (vga-sequencer-register i) x)) + (loop + ;; unlock CRTC registers + initially (setf (vga-crt-controller-register 3) + (logior #x80 (vga-crt-controller-register 3))) + (setf (vga-crt-controller-register #x11) + (logand #x7f (vga-crt-controller-register #x11))) + for x in (assert-register-set state :crtc) + as i upfrom 0 + do (setf (vga-crt-controller-register i) + (case i + ;; make sure they remain unlocked + (#x03 (logior #x80 x)) + (#x11 (logand #x7f x)) + (t x)))) + ;; write GRAPHICS CONTROLLER regs + (loop for x in (assert-register-set state :graphics) + as i upfrom 0 + do (setf (vga-graphics-register i) x)) + ;; write ATTRIBUTE CONTROLLER regs + (loop for x in (assert-register-set state :attribute) + as i upfrom 0 + do (setf (vga-attribute-register i) x)) + ;; lock 16-color palette and unblank display + (io-port VGA-INSTAT-READ :unsigned-byte8) + (setf (io-port VGA-AC-INDEX :unsigned-byte8) #x20) + (setf old-state nil)) (vga-reset)))) state) @@ -411,647 +411,647 @@ (defconstant +vga-font-8x8+ - #{#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 - #x7E #x81 #xA5 #x81 #xBD #x99 #x81 #x7E - #x7E #xFF #xDB #xFF #xC3 #xE7 #xFF #x7E - #x6C #xFE #xFE #xFE #x7C #x38 #x10 #x00 - #x10 #x38 #x7C #xFE #x7C #x38 #x10 #x00 - #x38 #x7C #x38 #xFE #xFE #x92 #x10 #x7C - #x00 #x10 #x38 #x7C #xFE #x7C #x38 #x7C - #x00 #x00 #x18 #x3C #x3C #x18 #x00 #x00 - #xFF #xFF #xE7 #xC3 #xC3 #xE7 #xFF #xFF - #x00 #x3C #x66 #x42 #x42 #x66 #x3C #x00 - #xFF #xC3 #x99 #xBD #xBD #x99 #xC3 #xFF - #x0F #x07 #x0F #x7D #xCC #xCC #xCC #x78 - #x3C #x66 #x66 #x66 #x3C #x18 #x7E #x18 - #x3F #x33 #x3F #x30 #x30 #x70 #xF0 #xE0 - #x7F #x63 #x7F #x63 #x63 #x67 #xE6 #xC0 - #x99 #x5A #x3C #xE7 #xE7 #x3C #x5A #x99 - #x80 #xE0 #xF8 #xFE #xF8 #xE0 #x80 #x00 - #x02 #x0E #x3E #xFE #x3E #x0E #x02 #x00 - #x18 #x3C #x7E #x18 #x18 #x7E #x3C #x18 - #x66 #x66 #x66 #x66 #x66 #x00 #x66 #x00 - #x7F #xDB #xDB #x7B #x1B #x1B #x1B #x00 - #x3E #x63 #x38 #x6C #x6C #x38 #x86 #xFC - #x00 #x00 #x00 #x00 #x7E #x7E #x7E #x00 - #x18 #x3C #x7E #x18 #x7E #x3C #x18 #xFF - #x18 #x3C #x7E #x18 #x18 #x18 #x18 #x00 - #x18 #x18 #x18 #x18 #x7E #x3C #x18 #x00 - #x00 #x18 #x0C #xFE #x0C #x18 #x00 #x00 - #x00 #x30 #x60 #xFE #x60 #x30 #x00 #x00 - #x00 #x00 #xC0 #xC0 #xC0 #xFE #x00 #x00 - #x00 #x24 #x66 #xFF #x66 #x24 #x00 #x00 - #x00 #x18 #x3C #x7E #xFF #xFF #x00 #x00 - #x00 #xFF #xFF #x7E #x3C #x18 #x00 #x00 - #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 - #x18 #x3C #x3C #x18 #x18 #x00 #x18 #x00 - #x6C #x6C #x6C #x00 #x00 #x00 #x00 #x00 - #x6C #x6C #xFE #x6C #xFE #x6C #x6C #x00 - #x18 #x7E #xC0 #x7C #x06 #xFC #x18 #x00 - #x00 #xC6 #xCC #x18 #x30 #x66 #xC6 #x00 - #x38 #x6C #x38 #x76 #xDC #xCC #x76 #x00 - #x30 #x30 #x60 #x00 #x00 #x00 #x00 #x00 - #x18 #x30 #x60 #x60 #x60 #x30 #x18 #x00 - #x60 #x30 #x18 #x18 #x18 #x30 #x60 #x00 - #x00 #x66 #x3C #xFF #x3C #x66 #x00 #x00 - #x00 #x18 #x18 #x7E #x18 #x18 #x00 #x00 - #x00 #x00 #x00 #x00 #x00 #x18 #x18 #x30 - #x00 #x00 #x00 #x7E #x00 #x00 #x00 #x00 - #x00 #x00 #x00 #x00 #x00 #x18 #x18 #x00 - #x06 #x0C #x18 #x30 #x60 #xC0 #x80 #x00 - #x7C #xCE #xDE #xF6 #xE6 #xC6 #x7C #x00 - #x30 #x70 #x30 #x30 #x30 #x30 #xFC #x00 - #x78 #xCC #x0C #x38 #x60 #xCC #xFC #x00 - #x78 #xCC #x0C #x38 #x0C #xCC #x78 #x00 - #x1C #x3C #x6C #xCC #xFE #x0C #x1E #x00 - #xFC #xC0 #xF8 #x0C #x0C #xCC #x78 #x00 - #x38 #x60 #xC0 #xF8 #xCC #xCC #x78 #x00 - #xFC #xCC #x0C #x18 #x30 #x30 #x30 #x00 - #x78 #xCC #xCC #x78 #xCC #xCC #x78 #x00 - #x78 #xCC #xCC #x7C #x0C #x18 #x70 #x00 - #x00 #x18 #x18 #x00 #x00 #x18 #x18 #x00 - #x00 #x18 #x18 #x00 #x00 #x18 #x18 #x30 - #x18 #x30 #x60 #xC0 #x60 #x30 #x18 #x00 - #x00 #x00 #x7E #x00 #x7E #x00 #x00 #x00 - #x60 #x30 #x18 #x0C #x18 #x30 #x60 #x00 - #x3C #x66 #x0C #x18 #x18 #x00 #x18 #x00 - #x7C #xC6 #xDE #xDE #xDC #xC0 #x7C #x00 - #x30 #x78 #xCC #xCC #xFC #xCC #xCC #x00 - #xFC #x66 #x66 #x7C #x66 #x66 #xFC #x00 - #x3C #x66 #xC0 #xC0 #xC0 #x66 #x3C #x00 - #xF8 #x6C #x66 #x66 #x66 #x6C #xF8 #x00 [1230 lines skipped]

1 0

[movitz-cvs] CVS movitz/losp/x86-pc
by ffjeld 07 Apr '07

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory clnet:/tmp/cvs-serv26544 Modified Files: pci.lisp Log Message: For scan-pci-bus, make bus 0 the default. --- /project/movitz/cvsroot/movitz/losp/x86-pc/pci.lisp 2005/08/24 07:33:21 1.12 +++ /project/movitz/cvsroot/movitz/losp/x86-pc/pci.lisp 2007/04/07 08:03:03 1.13 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Dec 14 22:33:42 2003 ;;;; -;;;; $Id: pci.lisp,v 1.12 2005/08/24 07:33:21 ffjeld Exp $ +;;;; $Id: pci.lisp,v 1.13 2007/04/07 08:03:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -308,7 +308,7 @@ (t (list (pop mem-keys) (logand base -16)))))) -(defun scan-pci-bus (bus) +(defun scan-pci-bus (&optional (bus 0)) (loop for device from 0 to 31 do (multiple-value-bind (vendor-id return-code) (pci-bios-config-space-word bus device 0 0)

1 0

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

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26494 Modified Files: symbols.lisp Log Message: Add gentemp. --- /project/movitz/cvsroot/movitz/losp/muerte/symbols.lisp 2007/02/22 22:11:21 1.28 +++ /project/movitz/cvsroot/movitz/losp/muerte/symbols.lisp 2007/04/07 08:02:35 1.29 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 23:55:41 2001 ;;;; -;;;; $Id: symbols.lisp,v 1.28 2007/02/22 22:11:21 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.29 2007/04/07 08:02:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -246,6 +246,14 @@ (make-symbol (format nil "~A~D" x (prog1 *gensym-counter* (incf *gensym-counter*))))))) +(defvar *gentemp-counter* 0) + +(defun gentemp (&optional (prefix "T") (package *package*)) + (intern (do ((name #0=(format nil "~A~D" prefix *gentemp-counter*) #0#)) + ((not (find-symbol name package)) name) + (incf *gentemp-counter*)) + package)) + (defun get (symbol indicator &optional default) (getf (symbol-plist symbol) indicator default))

1 0

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

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26392 Modified Files: inspect.lisp Log Message: Add a recursion limit to objects-equalp. --- /project/movitz/cvsroot/movitz/losp/muerte/inspect.lisp 2007/03/16 19:50:47 1.58 +++ /project/movitz/cvsroot/movitz/losp/muerte/inspect.lisp 2007/04/07 08:01:41 1.59 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.58 2007/03/16 19:50:47 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.59 2007/04/07 08:01:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -268,22 +268,24 @@ (run-time-context (%shallow-copy-object old (movitz-type-word-size 'movitz-run-time-context))))) -(defun objects-equalp (x y) +(defun objects-equalp (x y &optional (limit 20)) "Basically, this verifies whether x is a shallow-copy of y, or vice versa." (assert (not (with-inline-assembly (:returns :boolean-zf=1) (:load-lexical (:lexical-binding x) :eax) (:cmpl #x13 :eax))) (x) "Checking illegal ~S for object-equalp." x) - (or (eql x y) + (or (= 0 (decf limit)) + (eql x y) (cond - ((not (objects-equalp (class-of x) (class-of y))) + ((not (objects-equalp (class-of x) (class-of y) limit)) nil) ((not (and (typep x 'pointer) (typep y 'pointer))) nil) (t (macrolet ((test (accessor &rest args) `(objects-equalp (,accessor x ,@args) - (,accessor y ,@args)))) + (,accessor y ,@args) + limit))) (typecase x (bignum (= x y))

1 0

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

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24550 Modified Files: sequences.lisp Log Message: Fix a rather nasty bug in reduce when :end nil was specified for a vector sequence: The length never got computed and the vector would be accessed out of bounds (and so cause all sorts of strange effects). --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2007/03/21 20:20:33 1.35 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2007/04/07 07:59:31 1.36 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.35 2007/03/21 20:20:33 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.36 2007/04/07 07:59:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -124,57 +124,75 @@ ((= index end) result) (declare (index index))))))))))) (t (function sequence &key (key 'identity) from-end - (start 0) (end (length sequence)) + (start 0) end (initial-value nil initial-value-p)) (let ((start (check-the index start))) (with-funcallable (funcall-function function) (with-funcallable (key) - (case (- end start) - (0 (if initial-value-p - initial-value - (funcall-function))) - (1 (if initial-value-p - (funcall-function initial-value (key (elt sequence start))) - (key (elt sequence start)))) - (t (sequence-dispatch sequence - (list - (cond - ((not from-end) - (do* ((counter (1+ start) (1+ counter)) - (list (nthcdr start sequence)) - (result (funcall-function (if initial-value-p - initial-value - (key (pop list))) - (key (pop list))) - (funcall-function result (key (pop list))))) - ((or (null list) - (= end counter)) - result) - (declare (index counter)))) - (from-end - (do* ((counter (1+ start) (1+ counter)) - (list (nreverse (subseq sequence start end))) - (result (funcall-function (key (pop list)) - (if initial-value-p - initial-value - (key (pop list)))) - (funcall-function (key (pop list)) result))) - ((or (null list) - (= end counter)) - result) - (declare (index counter)))))) - (vector - (when from-end - (error "REDUCE from-end on vectors is not implemented.")) - (with-subvector-accessor (sequence-ref sequence start end) - (do* ((index start) - (result (funcall-function (if initial-value-p - initial-value - (key (sequence-ref (prog1 index (incf index))))) - (key (sequence-ref (prog1 index (incf index))))) - (funcall-function result (sequence-ref (prog1 index (incf index)))))) - ((= index end) result) - (declare (index index)))))))))))))) + (sequence-dispatch sequence + (list + (let ((list (nthcdr start sequence))) + (cond + ((null list) + (if initial-value-p + initial-value + (funcall-function))) + ((null (cdr list)) + (if initial-value-p + (funcall-function initial-value (key (car list))) + (key (car list)))) + ((not from-end) + (if (not end) + (do ((result (funcall-function (if initial-value-p + initial-value + (key (pop list))) + (key (pop list))) + (funcall-function result (key (pop list))))) + ((null list) result)) + (do ((counter (1+ start) (1+ counter)) + (result (funcall-function (if initial-value-p + initial-value + (key (pop list))) + (key (pop list))) + (funcall-function result (key (pop list))))) + ((or (null list) + (= end counter)) + result) + (declare (index counter))))) + (from-end + (do* ((end (or end (+ start (length list)))) + (counter (1+ start) (1+ counter)) + (list (nreverse (subseq sequence start end))) + (result (funcall-function (key (pop list)) + (if initial-value-p + initial-value + (key (pop list)))) + (funcall-function (key (pop list)) result))) + ((or (null list) + (= end counter)) + result) + (declare (index counter))))))) + (vector + (when from-end + (error "REDUCE from-end on vectors is not implemented.")) + (let ((end (or (check-the index end) + (length sequence)))) + (case (- end start) + (0 (if initial-value-p + initial-value + (funcall-function))) + (1 (if initial-value-p + (funcall-function initial-value (key (elt sequence start))) + (key (elt sequence start)))) + (t (with-subvector-accessor (sequence-ref sequence start end) + (do* ((index start) + (result (funcall-function (if initial-value-p + initial-value + (key (sequence-ref (prog1 index (incf index))))) + (key (sequence-ref (prog1 index (incf index))))) + (funcall-function result (sequence-ref (prog1 index (incf index)))))) + ((= index end) result) + (declare (index index))))))))))))))) (defun subseq (sequence start &optional end) (sequence-dispatch sequence @@ -1569,6 +1587,25 @@ (right (1- end)) left-item right-item) (declare (index left right)) + ;; do median-of-three.. + (let ((p1 (vector-ref start)) + (p2 (vector-ref (+ start cut-off -1))) + (p3 (vector-ref (1- end)))) + (let ((kp1 (key p1)) + (kp2 (key p2)) + (kp3 (key p3))) + (cond + ((predicate p1 p2) + (if (predicate p2 p3) + (setf pivot p2 keyed-pivot kp2) + (if (predicate p1 p3) + (setf pivot p3 keyed-pivot kp3) + (setf pivot p1 keyed-pivot kp1)))) + ((predicate p2 p3) + (if (predicate p1 p3) + (setf pivot p1 keyed-pivot kp1) + (setf pivot p3 keyed-pivot kp3))) + (t (setf pivot p2 keyed-pivot kp2))))) partitioning-loop (do-while (not (predicate keyed-pivot (key (setf left-item (vector-ref left))))) (incf left) @@ -1586,8 +1623,10 @@ partitioning-complete (setf (vector-ref start) right-item ; (aref vector right) (vector-ref right) pivot) - (quick-sort vector predicate key start right cut-off) - (quick-sort vector predicate key (1+ right) end cut-off)))))))) + (when (and (> cut-off (- right start)) + (> cut-off (- end right))) + (quick-sort vector predicate key start right cut-off) + (quick-sort vector predicate key (1+ right) end cut-off))))))))) vector) (defun sort (sequence predicate &key (key 'identity))

1 0

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

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24391 Modified Files: integers.lisp Log Message: Fix bug that would return nil from (- nil 0) rather than err. --- /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2006/05/02 20:02:09 1.122 +++ /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2007/04/07 07:56:45 1.123 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.122 2006/05/02 20:02:09 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.123 2007/04/07 07:56:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -622,7 +622,7 @@ (macrolet ((do-it () `(number-double-dispatch (minuend subtrahend) - ((t (eql 0)) + ((number (eql 0)) minuend) (((eql 0) t) (- subtrahend))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 05 Apr '07

05 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv29180 Modified Files: scavenge.lisp Log Message: In map-header-vals fix scanning of not-entirely-initialized funobjs. Add map-header-vals*, mostly as a debugging tool. --- /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2007/03/16 22:13:55 1.59 +++ /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2007/04/05 21:12:19 1.60 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.59 2007/03/16 22:13:55 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.60 2007/04/05 21:12:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -40,6 +40,11 @@ (unless (eq object new-object) (setf (memref location 0) new-object))))))) +(defun map-header-vals* (function &optional (vector (%run-time-context-slot nil 'nursery-space))) + (check-type vector (vector (unsigned-byte 32))) + (let ((location (+ 2 (object-location vector)))) + (map-header-vals function location (+ location (length vector))))) + (defun map-header-vals (function start-location end-location) "Map function over each potential pointer word between start-location and end-location." @@ -106,7 +111,9 @@ (record-scan (%word-offset scan #.(movitz:tag :other))) ;; Process code-vector pointers specially.. (let* ((old-code-vector (memref (incf scan) 0 :type :code-vector)) - (new-code-vector (map-instruction-pointer function scan old-code-vector))) + (new-code-vector (if (eq 0 old-code-vector) + 0 ; i.e. a non-initialized funobj. + (map-instruction-pointer function scan old-code-vector)))) (cond ((not (eq new-code-vector old-code-vector)) ;; Code-vector%1op

1 0

[movitz-cvs] CVS movitz
by ffjeld 05 Apr '07

05 Apr '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv29011 Modified Files: compiler.lisp Log Message: Fix a bug in code for initializing a stack-allocated funobj: The initial code-vector slot should be 2 rather than 0 in order to be GC-safe. --- /project/movitz/cvsroot/movitz/compiler.lisp 2007/03/21 19:57:52 1.185 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2007/04/05 21:10:39 1.186 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.185 2007/03/21 19:57:52 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.186 2007/04/05 21:10:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -7417,7 +7417,7 @@ (:pushl 0) ; %3op (:pushl 0) ; %2op (:pushl 0) ; %1op - (:pushl 0) ; (default) + (:pushl 2) ; (default) 2 is recognized by map-header-vals as non-initialized funobj. (:pushl (:eax ,(slot-offset 'movitz-funobj 'type))) (:leal (:esp ,(tag :other)) :ebx)

1 0

[movitz-cvs] CVS movitz
by ffjeld 02 Apr '07

02 Apr '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv29414 Modified Files: special-operators-cl.lisp Log Message: For the block special operator, we need to ensure that the body-code resets the stack-pointer (which it won't, for result-mode :function). This fixes a hard crash on ansi-test assoc.25. --- /project/movitz/cvsroot/movitz/special-operators-cl.lisp 2007/03/19 21:09:26 1.51 +++ /project/movitz/cvsroot/movitz/special-operators-cl.lisp 2007/04/02 20:54:34 1.52 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.51 2007/03/19 21:09:26 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.52 2007/04/02 20:54:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -860,7 +860,9 @@ (compiler-values-bind (&code block-code &functional-p block-no-side-effects-p) (compiler-call #'compile-form :defaults forward - :result-mode block-result-mode + :result-mode (case block-result-mode + (:function :multiple-values) ; must restore stack + (t block-result-mode)) :form `(muerte.cl:progn ,@body) :env block-env) (let ((label-set-name (gensym "block-label-set-"))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 01 Apr '07

01 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv12646 Modified Files: arithmetic-macros.lisp Log Message: Removed useless check-type in * compiler-macro. --- /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2007/04/01 19:05:07 1.18 +++ /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2007/04/01 19:22:22 1.19 @@ -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.18 2007/04/01 19:05:07 ffjeld Exp $ +;;;; $Id: arithmetic-macros.lisp,v 1.19 2007/04/01 19:22:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -257,7 +257,6 @@ `(* ,(movitz:movitz-eval factor2 env) ,factor1)) ((movitz:movitz-constantp factor1 env) (let ((f1 (movitz:movitz-eval factor1 env))) - (check-type f1 integer) (case f1 (0 `(progn ,factor2 0)) (1 factor2)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 01 Apr '07

01 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv9951 Modified Files: arithmetic-macros.lisp Log Message: Remove unreachable code. --- /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2007/03/20 22:40:41 1.17 +++ /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2007/04/01 19:05:07 1.18 @@ -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.17 2007/03/20 22:40:41 ffjeld Exp $ +;;;; $Id: arithmetic-macros.lisp,v 1.18 2007/04/01 19:05:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -43,9 +43,7 @@ (:testb 1 :cl))) (define-compiler-macro + (&whole form &rest operands &environment env) - (flet ((term (x) (if (and nil (symbolp x)) - (gensym (format nil "term-~A-" x)) - (gensym "term-")))) + (flet ((term (x) (gensym "term-"))) (case (length operands) (0 0) (1 (first operands))

1 0

[movitz-cvs] CVS movitz
by ffjeld 01 Apr '07

01 Apr '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv32157 Modified Files: image.lisp Log Message: Remove useless assertion. --- /project/movitz/cvsroot/movitz/image.lisp 2007/03/16 17:40:43 1.112 +++ /project/movitz/cvsroot/movitz/image.lisp 2007/04/01 18:18:26 1.113 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.112 2007/03/16 17:40:43 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.113 2007/04/01 18:18:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,10 +28,7 @@ (raw-scratch0 ; A non-GC-root scratch register :binary-type lu32 :initform 0) - - (pointer-start :binary-type :label) - (ret-trampoline :binary-type code-vector-word :map-binary-write 'movitz-intern-code-vector @@ -836,7 +833,6 @@ (or (ignore-errors (file-position stream position)) (let* ((end (file-position stream :end)) (diff (- position end))) - (assert (< 0 diff 10000)) (dotimes (i diff) (write-byte 0 stream)) (assert (= position (file-position stream)))))

1 0