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

[movitz-cvs] CVS movitz/ide
by ffjeld 09 Apr '07

09 Apr '07

Update of /project/movitz/cvsroot/movitz/ide In directory clnet:/tmp/cvs-serv14958 Modified Files: ide.lisp Log Message: Add movitz-disassemble-primitive. --- /project/movitz/cvsroot/movitz/ide/ide.lisp 2007/03/13 20:42:11 1.6 +++ /project/movitz/cvsroot/movitz/ide/ide.lisp 2007/04/09 15:59:43 1.7 @@ -13,6 +13,7 @@ #:compile-defun #:dump-image #:movitz-disassemble + #:movitz-disassemble-primitive #:movitz-disassemble-method #:movitz-arglist #:movitz-macroexpand)) @@ -49,6 +50,13 @@ (movitz:movitz-disassemble (get-sexpr printname (get-package package-printname)))))) +(defun movitz-disassemble-primitive (printname package-printname) + "Return the disassembly of SYMBOL-NAME's function as a string." + (with-image () + (with-output-to-string (*standard-output*) + (movitz::movitz-disassemble-primitive (get-sexpr printname + (get-package package-printname)))))) + (defun movitz-disassemble-method (gf-name lambda-list qualifiers package-name) (with-image () (let ((package (get-package package-name)))

1 0

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

08 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv19367 Modified Files: arrays.lisp Log Message: Remove lingering debug statement. --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/04/08 15:52:33 1.63 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/04/08 16:03:53 1.64 @@ -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.63 2007/04/08 15:52:33 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.64 2007/04/08 16:03:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1100,7 +1100,6 @@ (do-it)))) (cond ((integerp fill-pointer) - (warn "sfp len: ~s" (array-dimension array 0)) (setf (fill-pointer array) fill-pointer)) ((or (eq t fill-pointer) (array-has-fill-pointer-p array))

1 0

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

08 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16794 Modified Files: arrays.lisp Log Message: Fixed a stupid bug in (setf fill-pointer) which made make-array fail on vectors of length between #x1000 and #x4000. --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/04/07 20:18:20 1.62 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/04/08 15:52:33 1.63 @@ -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.62 2007/04/07 20:18:20 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.63 2007/04/08 15:52:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -157,7 +157,7 @@ "Does the basic-vector have a fill-pointer?" `(with-inline-assembly (:returns :boolean-zf=1) (:compile-form (:result-mode :eax) ,vector) - (:testl ,(logxor #xffffffff (1- (expt 2 14))) + (:testl ,(logxor #xffffffff (* movitz:+movitz-fixnum-factor+ (1- (expt 2 14)))) (:eax ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))))) (define-compiler-macro %basic-vector-fill-pointer (vector) @@ -232,7 +232,8 @@ (:jnz 'illegal-fill-pointer) (:movl (:ebx (:offset movitz-basic-vector num-elements)) :ecx) - (:testl ,(logxor #xffffffff (1- (expt 2 14))) :ecx) + (:testl ,(logxor #xffffffff (* movitz:+movitz-fixnum-factor+ (1- (expt 2 14)))) + :ecx) (:jnz '(:sub-program () (:compile-form (:result-mode :ignore) (error "Vector has no fill-pointer.")))) @@ -1099,6 +1100,7 @@ (do-it)))) (cond ((integerp fill-pointer) + (warn "sfp len: ~s" (array-dimension array 0)) (setf (fill-pointer array) fill-pointer)) ((or (eq t fill-pointer) (array-has-fill-pointer-p array))

1 0

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

08 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27055 Modified Files: ratios.lisp Log Message: Add some silly and slow cos and sin functions. --- /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp 2007/03/16 19:49:24 1.9 +++ /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp 2007/04/08 13:44:44 1.10 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 20 00:39:59 2004 ;;;; -;;;; $Id: ratios.lisp,v 1.9 2007/03/16 19:49:24 ffjeld Exp $ +;;;; $Id: ratios.lisp,v 1.10 2007/04/08 13:44:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -76,9 +76,28 @@ (integer 1) (ratio (%ratio-denominator x)))) -(defconstant pi #xea7632a/4aa1a8b) - (defconstant least-positive-short-float 1/1000) (defconstant least-positive-single-float 1/1000) (defconstant least-positive-double-float 1/1000) (defconstant least-positive-long-float 1/1000) + +;;; + +(defconstant pi #xea7632a/4aa1a8b) + +(defvar long-float-epsilon 1/10000) + +(defun cos (x) + "http://mathworld.wolfram.com/Cosine.html" + (do* ((rad (mod x 44/7)) + (n2 0 (+ n2 2)) + (sign 1 (- sign)) + (denominator 1 (* denominator (1- n2) n2)) + (term 1 (/ (expt rad n2) + denominator)) + (sum 1 (+ sum (* sign term)))) + ((<= term long-float-epsilon) + sum))) + +(defun sin (x) + (cos (- x (/ pi 2))))

1 0

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

08 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv22352 Modified Files: format.lisp Log Message: Format-float was completely broken: It tried to round off when printing the last digit, but that must be done initially, in case of "overflow". --- /project/movitz/cvsroot/movitz/losp/muerte/format.lisp 2007/02/11 21:57:14 1.15 +++ /project/movitz/cvsroot/movitz/losp/muerte/format.lisp 2007/04/08 13:14:58 1.16 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Mar 23 01:18:36 2002 ;;;; -;;;; $Id: format.lisp,v 1.15 2007/02/11 21:57:14 ffjeld Exp $ +;;;; $Id: format.lisp,v 1.16 2007/04/08 13:14:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -68,24 +68,22 @@ ((minusp x) (write-char #\-) (format-float (- x) at-sign-p colon-p w d k overflowchar padchar)) - (t (multiple-value-bind (integer-part decimal-part) - (truncate x) - (write-integer integer-part *standard-output* 10 nil) - (dotimes (i k) - (write-char #\0)) - (write-char #\.) - (do ((remainder decimal-part) - (last-i (if d (1- d) 15)) - (i 0 (1+ i))) - ((or (and (not d) (plusp i) (zerop remainder)) - (> i last-i))) - (declare (index i)) - (multiple-value-bind (next-digit next-remainder) - (if (= i last-i) - (floor (+ 1/2 (* 10 remainder))) - (truncate (* 10 remainder))) - (setf remainder next-remainder) - (write-digit next-digit *standard-output*))))))) + (t (let ((decimals (if d (1- d) 15))) + (multiple-value-bind (integer-part decimal-part) + (truncate (+ x (* 1/20 (expt 1/10 decimals)))) + (write-integer integer-part *standard-output* 10 nil) + (dotimes (i k) + (write-char #\0)) + (write-char #\.) + (do ((remainder decimal-part) + (i 0 (1+ i))) + ((or (and (not d) (plusp i) (zerop remainder)) + (> i decimals))) + (declare (index i)) + (multiple-value-bind (next-digit next-remainder) + (truncate (* 10 remainder)) + (setf remainder next-remainder) + (write-digit next-digit *standard-output*)))))))) (defun find-directive (string i directive &optional recursive-skip-start (recursive-skip-end directive))

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-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