movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[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

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

31 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory clnet:/tmp/cvs-serv16093 Modified Files: keyboard.lisp Log Message: Patch from Philippe Brochard: Attached is a french keyboard layout for movitz. Like qwerty or dvorak but for french people. --- /project/movitz/cvsroot/movitz/losp/x86-pc/keyboard.lisp 2007/03/14 20:42:48 1.7 +++ /project/movitz/cvsroot/movitz/losp/x86-pc/keyboard.lisp 2007/03/31 21:08:13 1.8 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Sep 24 16:04:12 2001 ;;;; -;;;; $Id: keyboard.lisp,v 1.7 2007/03/14 20:42:48 ffjeld Exp $ +;;;; $Id: keyboard.lisp,v 1.8 2007/03/31 21:08:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -77,6 +77,53 @@ #\B #\N #\M #\< #\> #\? nil nil ; #x30 nil nil nil nil nil nil nil nil ; #x38 nil nil nil nil nil :pause nil nil)) ; #xd8 + (:azerty + #(#\null #\escape #\& #\~ #\" #\' #$ #\- ; #x00 + #\` #\_ #\| #\@ #$ #\= #\backspace #\tab ; #x08 + #\a #\z #\e #\r #\t #\y #\u #\i ; #x10 + #\o #\p #\^ #\$ #\newline :ctrl-left #\q #\s ; #x18 + + #\d #\f #\g #\h #\j #\k #\l #\m ; #x20 + #\% #\# :shift-left #\* #\w #\x #\c #\v ; #x28 + #\b #\n #\, #\; #\: #\! :shift-right #\escape ; #x30 + :alt-left #\space :caps-lock :f1 :f2 :f3 :f4 :f5 ; #x38 + + :f6 :f7 :f8 :f9 :f10 :break :scroll-lock nil ; #x40 + nil nil nil nil nil nil nil nil ; #x48 + nil :kp-ins nil :kp-del nil nil #\< :f11 ; #x50 + :f12 nil nil nil nil nil nil nil ; #x58 + + nil nil nil nil nil nil nil nil ; #x60 + nil nil nil nil nil nil nil nil ; #x68 + nil nil nil nil nil nil nil nil ; #x70 + nil nil nil nil nil nil nil nil ; #x78 + + nil nil nil nil nil nil nil nil ; #x80 + nil nil nil nil nil nil nil nil ; #x88 + nil nil nil nil :ctrl-right nil nil nil ; #x90 + nil nil nil nil nil :ctrl-right nil nil ; #x98 + + nil nil nil nil nil nil nil nil ; #xa0 + nil nil nil nil nil nil nil nil ; #xa8 + nil nil nil nil nil nil nil nil ; #xb0 + :alt-right nil nil nil nil nil nil nil ; #xb8 + + nil nil nil nil nil nil nil :home ; #xc0 + :up :page-up nil :left nil :right nil :end ; #xc8 + :down :page-down :insert nil #+ignore #\delete nil nil nil nil nil ; #xd0 + :alt-right nil nil nil :win :menu nil nil) ; #x40 + #(#\null nil #\1 #\2 #\3 #\4 #\5 #\6 ; #x00 + #\7 #\8 #\9 #\0 #\A #\+ nil nil ; #x08 + #\A #\Z #\E #\R #\T #\Y #\U #\I ; #x10 + #\O #\P #\{ #\} #\newline nil #\Q #\S ; #x18 + + #\D #\F #\G #\H #\J #\K #\L #\M ; #x20 + #\[ #\| nil #\] #\W #\X #\C #\V ; #x28 + #\B #\N #\? #\. #\/ #\\ nil nil ; #x30 + nil nil nil nil nil nil nil nil ; #x38 + nil nil nil nil nil :pause nil nil ; #x40 + nil nil nil nil nil nil nil nil ; #x48 + nil nil nil nil nil nil #\> nil)) ; #x50 (:dvorak #(#\null #\escape #\1 #\2 #\3 #\4 #\5 #\6 ; #x00 #\7 #\8 #\9 #\0 #\[ #\] #\backspace #\tab ; #x08

1 0

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

26 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory clnet:/tmp/cvs-serv24451 Modified Files: textmode.lisp Log Message: Added *text-output-port* to take advantage of bochs' 0xe9 port hack. --- /project/movitz/cvsroot/movitz/losp/x86-pc/textmode.lisp 2005/08/26 21:42:39 1.15 +++ /project/movitz/cvsroot/movitz/losp/x86-pc/textmode.lisp 2007/03/26 21:43:21 1.16 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 9 15:38:56 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: textmode.lisp,v 1.15 2005/08/26 21:42:39 ffjeld Exp $ +;;;; $Id: textmode.lisp,v 1.16 2007/03/26 21:43:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -23,6 +23,9 @@ (in-package muerte.x86-pc) +(defvar *text-output-port* nil + "Output all text also to this port. For example, bochs #xe9 port hack.") + (defvar *screen* (vga-memory-map)) @@ -67,6 +70,8 @@ value) (defun textmode-write-char (c) + (when *text-output-port* + (setf (io-port *text-output-port* :unsigned-byte8) (char-code c))) (case c (#\newline (setf *cursor-x* 0)

1 0

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

26 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv18149 Modified Files: interrupt.lisp Log Message: Fix error condition when funcalling a non-function. --- /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2007/02/22 21:03:50 1.54 +++ /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2007/03/26 21:11:43 1.55 @@ -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.54 2007/02/22 21:03:50 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.55 2007/03/26 21:11:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -344,7 +344,7 @@ (with-inline-assembly (:returns :nothing) (:nop)))) (69 (error 'type-error :datum (dereference $eax) - :expected-type (aref #(cons) + :expected-type (aref #(cons function) (dereference $ecx :unsigned-byte8)))) (70 (error "Unaligned memref access.")) ((5 55)

1 0

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

26 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv18123 Modified Files: basic-macros.lisp Log Message: Fix error condition when funcalling a non-function. --- /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2007/02/22 21:03:10 1.69 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2007/03/26 21:11:40 1.70 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.69 2007/02/22 21:03:10 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.70 2007/03/26 21:11:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -755,6 +755,7 @@ not-symbol (:cmpb 7 :cl) (:jne '(:sub-program (not-funobj) + (:movb 1 :cl) (:int 69))) (:cmpb ,(movitz:tag :funobj) (:edx ,movitz:+other-type-offset+)) (:jne 'not-funobj) @@ -805,6 +806,7 @@ (:leal (:edx -6) :ecx) (:testb 7 :cl) (:jne '(:sub-program (not-funobj) + (:movb 1 :cl) (:int 69))) (:cmpb ,(movitz::tag :funobj) (:edx ,movitz:+other-type-offset+)) (:jne 'not-funobj) @@ -827,6 +829,7 @@ not-symbol (:cmpb 7 :cl) (:jnz '(:sub-program (not-funobj) + (:movb 1 :cl) (:int 69))) (:cmpb ,(movitz::tag :funobj) (:edx ,movitz:+other-type-offset+)) (:jne 'not-funobj) @@ -849,6 +852,7 @@ not-symbol (:cmpb 7 :cl) (:jnz '(:sub-program (not-funobj) + (:movb 1 :cl) (:int 69))) (:cmpb ,(movitz::tag :funobj) (:edx ,movitz:+other-type-offset+)) (:jne 'not-funobj)

1 0

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

26 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory clnet:/tmp/cvs-serv17914 Modified Files: vga.lisp Log Message: Patch from M. Bealby. --- /project/movitz/cvsroot/movitz/losp/x86-pc/vga.lisp 2007/03/21 21:49:11 1.11 +++ /project/movitz/cvsroot/movitz/losp/x86-pc/vga.lisp 2007/03/26 18:04:04 1.12 @@ -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.11 2007/03/21 21:49:11 ffjeld Exp $ +;;;; $Id: vga.lisp,v 1.12 2007/03/26 18:04:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -237,6 +237,7 @@ (defvar *vga-page-count* 0) (defvar *vga-width* 0) (defvar *vga-height* 0) +(defvar *vga-viewport* '(0 0 0 0)) (defconstant +vga-misc-read+ #x0c) (defconstant +vga-misc-write+ #x02) @@ -1117,18 +1118,45 @@ (g-clear)) (values)) +;; read a pixel from the DISPLAYED page +(defun pixel (x y) + (memref-int (vga-memory-map) + :index (+ (* (truncate *vga-width* 4) y) + (truncate x y) + (* (truncate *vga-width* 2) + *vga-height* + (mod (1+ *vga-current-page*) + *vga-page-count*))) + :type :unsigned-byte8)) + ;; set a pixel to a colour of our choice -;; always writing to the next page +;; write to the NEXT page (defun (setf pixel) (col x y) - (set-plane (logand x 3)) - (setf (memref-int (vga-memory-map) - :index (+ (* (truncate *vga-width* 4) y) ; pixel - (truncate x 4) - (* (truncate *vga-width* 2) ; page - *vga-height* - *vga-current-page*)) - :type :unsigned-byte8) - col)) + (cond ((< x (nth 0 (viewport))) (return-from pixel nil)) + ((> x (nth 1 (viewport))) (return-from pixel nil)) + ((< y (nth 2 (viewport))) (return-from pixel nil)) + ((> y (nth 3 (viewport))) (return-from pixel nil)) + (t (set-plane (logand x 3)) + (setf (memref-int (vga-memory-map) + :index (+ (* (truncate *vga-width* 4) y) ; pixel + (truncate x 4) + (* (truncate *vga-width* 2) ; page + *vga-height* + *vga-current-page*)) + :type :unsigned-byte8) + col)))) + + +; return the current viewport as a list +(defun viewport () + *vga-viewport*) + + +; sets the viewport +; rectangle is a list of left-bound, right-bound, top-bound, bottom-bound +(defun (setf viewport) (rectangle) + (setf *vga-viewport* rectangle)) + ;; clear the screen (defun g-clear () @@ -1176,6 +1204,7 @@ (mod (1+ *vga-current-page*) *vga-page-count*))) + ;; easy way to get into graphics mode (defun g-start () (setf (vga-state) +vga-state-320x200x256-modex+) @@ -1183,6 +1212,7 @@ (setf *vga-height* 200) (setf *vga-page-count* 2) (setf *vga-current-page* 0) ; writing page + (setf (viewport) `(0 ,(1- *vga-width*) 0 ,(1- *vga-height*))) (unchain-video-mode) (g-clear) (page-flip))

1 0

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

21 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv10647 Modified Files: equalp.lisp Log Message: Fix equal: Support bit-vectors, be iterative rather than recursive on lists, etc. --- /project/movitz/cvsroot/movitz/losp/muerte/equalp.lisp 2005/08/26 19:38:56 1.7 +++ /project/movitz/cvsroot/movitz/losp/muerte/equalp.lisp 2007/03/21 21:54:12 1.8 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 13 17:09:08 2001 ;;;; -;;;; $Id: equalp.lisp,v 1.7 2005/08/26 19:38:56 ffjeld Exp $ +;;;; $Id: equalp.lisp,v 1.8 2007/03/21 21:54:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -26,18 +26,24 @@ (defun equal (x y) (typecase x + (symbol + (eq x y)) (string (and (stringp y) (string= x y))) - (symbol - (eq x y)) (number - (and (numberp y) - (= x y))) + (eql x y)) (cons - (and (consp y) - (equal (car x) (car y)) - (equal (cdr x) (cdr y)))) + (when (consp y) + (do () + ((not (equal (pop x) (pop y))) + nil) + (when (or (not (consp x)) + (not (consp y))) + (return (equal x y)))))) + (bit-vector + (when (typep y 'bit-vector) + (not (mismatch x y)))) (t (eq x y)))) (defun equalp (x y)

1 0

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

21 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory clnet:/tmp/cvs-serv10270 Modified Files: vga.lisp Log Message: Patch from M. Bealby: "Double buffering, unchained mode support, optimised clear screen +routine, general tidy up for further expansion." --- /project/movitz/cvsroot/movitz/losp/x86-pc/vga.lisp 2007/03/17 15:39:26 1.10 +++ /project/movitz/cvsroot/movitz/losp/x86-pc/vga.lisp 2007/03/21 21:49:11 1.11 @@ -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.10 2007/03/17 15:39:26 ffjeld Exp $ +;;;; $Id: vga.lisp,v 1.11 2007/03/21 21:49:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -207,14 +207,14 @@ #x38 #x39 #x3A #x3B #x3C #x3D #x3E #x3F #x0C #x00 #x0F #x08 #x00))) -(defconstant +vga-state-320x200x256+ +(defconstant +vga-state-320x200x256-modex+ '((:misc . #x63) (:sequencer - #x03 #x01 #x0F #x00 #x0E) + #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 #x40 #x98 #xB9 #xA3 + #x9C #x0E #x8F #x28 #x00 #x96 #xB9 #xE3 #xFF) (:graphics #x00 #x00 #x00 #x00 #x00 #x40 #x05 #x0F @@ -225,24 +225,18 @@ #x41 #x00 #x0F #x00 #x00))) -;; 640x480 in testing, functions not available yet. -(defconstant +vga-state-640x480x16+ - '((:misc . #xE3) - (:sequencer - #x03 #x01 #x08 #x00 #x06) - (:crtc - #x5F #x4F #x50 #x82 #x54 #x80 #x0B #x3E - #x00 #x40 #x00 #x00 #x00 #x00 #x00 #x00 - #xEA #x0C #xDF #x28 #x00 #xE7 #x04 #xE3 - #xFF) - (:graphics - #x00 #x00 #x00 #x00 #x03 #x00 #x05 #x0F - #xFF) - (:attribute - #x00 #x01 #x02 #x03 #x04 #x05 #x14 #x07 - #x38 #x39 #x3A #x3B #x3C #x3D #x3E #x3F - #x01 #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 + +(defvar *vga-current-page* 0) +(defvar *vga-page-count* 0) +(defvar *vga-width* 0) +(defvar *vga-height* 0) (defconstant +vga-misc-read+ #x0c) (defconstant +vga-misc-write+ #x02) @@ -348,6 +342,15 @@ (setf (io-port VGA-SEQ-DATA :unsigned-byte8) pmask)) (values)) +(defun set-plane-by-bitmask (p) + (check-type p (integer 0 15)) + ;; set read plane + (setf (io-port VGA-GC-INDEX :unsigned-byte8) 4) + (setf (io-port VGA-GC-DATA :unsigned-byte8) p) + ;; set write plane + (setf (io-port VGA-SEQ-INDEX :unsigned-byte8) 2) + (setf (io-port VGA-SEQ-DATA :unsigned-byte8) p)) + (defun vmemwr (dst-off src start end) (loop for i from start below end as dst upfrom dst-off do (setf (memref-int (vga-memory-map) :index dst :type :unsigned-byte8) @@ -1083,18 +1086,23 @@ (progn ,@body) (restore-textmode ,vga-state-var))))) -;; graphics functions below: +;; graphics functions below ;; + + +;; TODO: This can be optimised through two methods +;; 1. Either write all of plane 1, then plane 2 etc (plane switches are slow) +;; 2. Use multiple plane writes at once (see g-clear for idea) +;; - Probably better because of large areas of the same colour (defun rle-blit-splash (splash) (loop with index = 0 for i from 0 below (length splash) by 2 for value = (aref splash i) for count = (1+ (aref splash (1+ i))) do (loop repeat count - do (setf (memref-int (vga-memory-map) - :index index - :type :unsigned-byte8) + do (setf (pixel (mod index *vga-width*) ; ugly hackitude :( + (truncate index *vga-width*)) value) (incf index))) nil) @@ -1102,35 +1110,82 @@ ;; show the splash screen (defun g-show-splash () (with-textmode-restored () - (setf (vga-state) +vga-state-320x200x256+) + (g-start) (rle-blit-splash *vga-g-splash*) + (page-flip) (read-char) (g-clear)) (values)) ;; set a pixel to a colour of our choice -(defun g-set-pixel (x y col) +;; always writing to the next page +(defun (setf pixel) (col x y) + (set-plane (logand x 3)) (setf (memref-int (vga-memory-map) - :index (+ (* 320 y) x) + :index (+ (* (truncate *vga-width* 4) y) ; pixel + (truncate x 4) + (* (truncate *vga-width* 2) ; page + *vga-height* + *vga-current-page*)) :type :unsigned-byte8) col)) -;; clear the graphics screen (simple method but slow) +;; clear the screen (defun g-clear () - (dotimes (y 240) - (dotimes (x 320) - (g-set-pixel x y 0)))) + ;; set read plane to all (bitmask 1111) + (set-plane-by-bitmask 15) + ;; writing to all 4 planes here thus 1/4 of the bytes + ;; and by writing 16 bits a time we get double plus good optimisation :) + ;; However, we wish to cover four planes, thus four times the memory + (loop for x from 0 below (* *vga-width* *vga-height*) + do (setf (memref-int (vga-memory-map) + :index x + :type :unsigned-byte16) + #x0000))) + + +(defun unchain-video-mode () + ;; disable chain-4 + (setf (io-port VGA-SEQ-INDEX :unsigned-byte8) #x04) + (setf (io-port VGA-SEQ-DATA :unsigned-byte8) #x06) + ;; disable long mode + (setf (io-port VGA-CRTC-INDEX :unsigned-byte8) #x14) + (setf (io-port VGA-CRTC-DATA :unsigned-byte8) #x00) + ;; enable byte mode + (setf (io-port VGA-CRTC-INDEX :unsigned-byte8) #x17) + (setf (io-port VGA-CRTC-DATA :unsigned-byte8) #xE3)) + + +(defun set-page (page) + (setf (io-port VGA-CRTC-INDEX :unsigned-byte8) #x0C) + (setf (io-port VGA-CRTC-DATA :unsigned-byte8) (ldb (byte 8 8) + (* page + (truncate *vga-width* 2) + *vga-height*))) + (setf (io-port VGA-CRTC-INDEX :unsigned-byte8) #x00) + (setf (io-port VGA-CRTC-DATA :unsigned-byte8) (ldb (byte 8 0) + (* page + (truncate *vga-width* 2) + *vga-height*)))) + + +;; Simple wrapper to swap pages +(defun page-flip () + (set-page *vga-current-page*) + (setf *vga-current-page* + (mod (1+ *vga-current-page*) + *vga-page-count*))) -;; easy way to get into / out of graphics mode +;; easy way to get into graphics mode (defun g-start () - (setf (vga-state) +vga-state-320x200x256+) - (g-clear)) - - -;; BUG (doesn't restore the text) -;; store on entering graphics state? -(defun g-exit () - (set-textmode +vga-state-80x25+)) + (setf (vga-state) +vga-state-320x200x256-modex+) + (setf *vga-width* 320) + (setf *vga-height* 200) + (setf *vga-page-count* 2) + (setf *vga-current-page* 0) ; writing page + (unchain-video-mode) + (g-clear) + (page-flip)) ;; draw-line from ch-image @@ -1152,7 +1207,7 @@ (x x0) (y y0)) (declare (type fixnum d incr-e incr-ne x y)) - (g-set-pixel y x col) + (setf (pixel y x) col) (dotimes (i absdx) (cond ((<= d 0) @@ -1162,14 +1217,14 @@ (incf d incr-ne) (incf x xstep) (incf y ystep))) - (g-set-pixel y x col))) + (setf (pixel y x) col))) (let ((d (- (* 2 absdy) absdx)) (incr-n (* 2 absdx)) (incr-ne (* 2 (- absdx absdy))) (x x0) (y y0)) (declare (type fixnum d incr-n incr-ne x y)) - (g-set-pixel y x col) + (setf (pixel y x) col) (dotimes (i absdy) (cond ((<= d 0) @@ -1179,9 +1234,7 @@ (incf d incr-ne) (incf y ystep) (incf x xstep))) - (g-set-pixel y x col)))))))) - - + (setf (pixel y x) col)))))))) ;; draw-circle from ch-image ;; originally written by Cyrus Harmon @@ -1189,14 +1242,14 @@ (defmethod draw-circle (center-y center-x radius col) (declare (type fixnum center-y center-x radius)) (flet ((circle-points (y x col) - (g-set-pixel (+ center-y y) (+ center-x x) col) - (g-set-pixel (+ center-y x) (+ center-x y) col) - (g-set-pixel (- center-y x) (+ center-x y) col) - (g-set-pixel (- center-y y) (+ center-x x) col) - (g-set-pixel (- center-y y) (- center-x x) col) - (g-set-pixel (- center-y x) (- center-x y) col) - (g-set-pixel (+ center-y x) (- center-x y) col) - (g-set-pixel (+ center-y y) (- center-x x) col))) + (setf (pixel (+ center-y y) (+ center-x x)) col) + (setf (pixel (+ center-y x) (+ center-x y)) col) + (setf (pixel (- center-y x) (+ center-x y)) col) + (setf (pixel (- center-y y) (+ center-x x)) col) + (setf (pixel (- center-y y) (- center-x x)) col) + (setf (pixel (- center-y x) (- center-x y)) col) + (setf (pixel (+ center-y x) (- center-x y)) col) + (setf (pixel (+ center-y y) (- center-x x)) col))) (let ((x 0) (y radius) (d (- 1 radius)) @@ -1218,8 +1271,6 @@ (incf x) (circle-points y x col))))) - - ;; additional drawing functions (rectangle / triangle) (defmethod draw-rectangle (x1 y1 x2 y2 col) (draw-line x1 y1 x1 y2 col)

1 0

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

21 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv30352 Modified Files: sequences.lisp Log Message: Add some (type index) declarations. --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2007/02/20 21:55:29 1.34 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2007/03/21 20:20:33 1.35 @@ -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.34 2007/02/20 21:55:29 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.35 2007/03/21 20:20:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -204,6 +204,7 @@ (head (cons (car list-start) nil)) (tail head)) ((or (endp p) (>= i end)) head) + (declare (index i)) (setf (cdr tail) (cons (car p) nil) tail (cdr tail))))))))) @@ -259,6 +260,7 @@ (do ((p (nthcdr start sequence)) (i start (1+ i))) ((null p) nil) + (declare (index i)) (when (test (key (pop p)) item) (return (if (not from-end) i @@ -306,10 +308,12 @@ ((not from-end) (do ((i start (1+ i))) ((>= i end)) + (declare (index i)) (when (predicate (key (sequence-ref i))) (return i)))) (t (do ((i (1- end) (1- i))) ((< i start)) + (declare (index i)) (when (predicate (key (sequence-ref i))) (return i))))))) (list @@ -318,6 +322,7 @@ (do ((p (nthcdr start sequence)) (i start (1+ i))) ((or (>= i end) (null p))) + (declare (index i)) (when (predicate (key (pop p))) (return (if (not from-end) i (let ((next-i (position-if predicate p :key key @@ -326,6 +331,7 @@ (t (do ((p (nthcdr start sequence)) (i start (1+ i))) ((null p)) + (declare (index i)) (when (predicate (key (pop p))) (return (if (not from-end) i (let ((next-i (position-if predicate p :key key :from-end t))) @@ -1851,12 +1857,14 @@ ((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) @@ -1864,12 +1872,14 @@ ((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) @@ -1884,6 +1894,7 @@ ((>= 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)))) @@ -1897,12 +1908,14 @@ (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) @@ -1912,6 +1925,7 @@ (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)

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs