movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[movitz-cvs] CVS update: movitz/image.lisp
by ffjeld＠common-lisp.net 09 Dec '04

09 Dec '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29777 Modified Files: image.lisp Log Message: Added function set-file-position that tolerats the behavior of CLisp's file-position (on windows). Date: Thu Dec 9 15:04:55 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.83 movitz/image.lisp:1.84 --- movitz/image.lisp:1.83 Thu Nov 25 19:05:17 2004 +++ movitz/image.lisp Thu Dec 9 15:04:54 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.83 2004/11/25 18:05:17 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.84 2004/12/09 14:04:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -846,6 +846,16 @@ *i* (when (boundp '*image*) *image*)) *image*) +(defun set-file-position (stream position &optional who) + (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))))) + (values)) + (defun dump-image (&key (path *default-image-file*) ((:image *image*) *image*) (multiboot-p t) ignore-dump-count) "When <multiboot-p> is true, include a MultiBoot-compliant header in the image." @@ -959,8 +969,7 @@ :direction :output :if-exists :supersede :if-does-not-exist :create) - (assert (file-position stream 512) () ; leave room for bootblock. - "Couldn't set file-position for ~W." (pathname stream)) + (set-file-position stream 512) ; leave room for bootblock. (let* ((stack-vector (make-instance 'movitz-basic-vector :num-elements #x3ffe :fill-pointer 0 @@ -978,12 +987,12 @@ (kernel-size (- image-end image-start))) (format t "~&;; Kernel size: ~D octets.~%" kernel-size) (unless (zerop (mod image-end 512)) ; Ensure image is multiple of 512 octets - (file-position stream (+ image-end (- 511 (mod image-end 512)))) + (set-file-position stream (+ image-end (- 511 (mod image-end 512))) 'pad-image-tail) (write-byte #x0 stream)) (format t "~&;; Image file size: ~D octets.~%" image-end) ;; Write simple stage1 bootblock into sector 0.. (format t "~&;; Dump count: ~D." (incf (dump-count *image*))) - (assert (file-position stream 0)) + (set-file-position stream 0) (flet ((global-slot-position (slot-name) (+ 512 (image-nil-word *image*) @@ -1004,13 +1013,12 @@ #+ignore(warn "stack-v-pos: ~S => ~S" stack-vector-position stack-vector-word) - (assert (file-position stream (global-slot-position 'stack-vector) - #+ignore stack-vector-position)) + (set-file-position stream (global-slot-position 'stack-vector) 'stack-vector) (write-binary 'word stream stack-vector-word) - (assert (file-position stream (global-slot-position 'stack-bottom))) + (set-file-position stream (global-slot-position 'stack-bottom) 'stack-bottom) (write-binary 'lu32 stream (+ 8 (* 4 4096) ; cushion (- stack-vector-word (tag :other)))) - (assert (file-position stream (global-slot-position 'stack-top))) + (set-file-position stream (global-slot-position 'stack-top) 'stack-top) (write-binary 'lu32 stream (+ 8 (- stack-vector-word (tag :other)) (* 4 (movitz-vector-num-elements stack-vector))))) (if (not multiboot-p) @@ -1030,10 +1038,7 @@ (warn "Multiboot header at position ~D is above the 8KB mark, ~ this image will not be Multiboot compatible." (+ mb-file-position (sizeof mb)))) - (assert (file-position stream mb-file-position) () - "Couldn't set file-position for ~W to ~W." - (pathname stream) - mb-file-position) + (set-file-position stream mb-file-position 'multiboot-header) ;; (format t "~&;; Multiboot load-address: #x~X." load-address) (setf (header-address mb) mb-address (load-address mb) load-address @@ -1077,7 +1082,7 @@ (assert (<= 0 pad-delta 31) () "pad-delta ~S for ~S, p: ~S, new-pos: ~S" pad-delta obj p new-pos)) (incf pad-size pad-delta)) - (assert (file-position stream new-pos))) + (set-file-position stream new-pos obj)) ;; (warn "Dump at address #x~X, filepos #x~X: ~A" p (file-position stream) obj) (let ((old-pos (file-position stream)) (write-size (write-binary-record obj stream))) @@ -1109,10 +1114,10 @@ (sum (+ symbols-size conses-size funobjs-size strings-size simple-vectors-size code-vectors-size pad-size))) (format t "~&;;~%;; ~D symbols (~D gensyms) (~,1F KB ~~ ~,1F%), ~D conses (~,1F KB ~~ ~,1F%), -;; ~D funobjs (~,1F KB ~~ ~,1F%), ~D strings (~,1F KB ~~ ~,1F%), -;; ~D simple-vectors (~,1F KB ~~ ~,1F%), ~D code-vectors (~,1F KB ~~ ~,1F%). -;; ~,1F KB (~,1F%) of padding. -;; In sum this accounts for ~,1F%, or ~D bytes.~%;;~%" +~D funobjs (~,1F KB ~~ ~,1F%), ~D strings (~,1F KB ~~ ~,1F%), +~D simple-vectors (~,1F KB ~~ ~,1F%), ~D code-vectors (~,1F KB ~~ ~,1F%). +~,1F KB (~,1F%) of padding. +In sum this accounts for ~,1F%, or ~D bytes.~%;;~%" symbols-numof gensyms-numof (/ symbols-size 1024) (/ (* symbols-size 100) total-size) conses-numof (/ conses-size 1024) (/ (* conses-size 100) total-size) @@ -1160,13 +1165,13 @@ (t #+ignore (warn "Package ~S ~@[for symbol ~S ~]is not a Movitz package." name symbol) name))) - (ensure-package (package-name lisp-package) + (ensure-package (package-name lisp-package &optional context) (assert (not (member (package-name lisp-package) #+allegro '(excl common-lisp sys aclmop) #-allegro '(common-lisp) :test #'string=)) () - "I don't think you really want to dump the package ~A with Movitz." - lisp-package) + "I don't think you really want to dump the package ~A ~@[for symbol ~S~] with Movitz." + lisp-package context) (setf (gethash lisp-package lisp-to-movitz-package) (or (gethash package-name packages-hash nil) (let ((p (funcall 'muerte::make-package-object @@ -1175,7 +1180,8 @@ :external-symbols (make-hash-table :test #'equal) :internal-symbols (make-hash-table :test #'equal) :use-list (mapcar #'(lambda (up) - (ensure-package (movitz-package-name (package-name up)) up)) + (ensure-package (movitz-package-name (package-name up)) + up context)) (package-use-list lisp-package))))) (setf (gethash package-name packages-hash) p) p))))) @@ -1188,7 +1194,7 @@ as package-name = (and lisp-package (movitz-package-name (package-name lisp-package) symbol)) when package-name - do (let* ((movitz-package (ensure-package package-name lisp-package))) + do (let* ((movitz-package (ensure-package package-name lisp-package symbol))) (multiple-value-bind (symbol status) (find-symbol (symbol-name symbol) (symbol-package symbol)) (ecase status @@ -1219,7 +1225,7 @@ ;;; do (when (string= symbol :method) ;;; (warn "XXXX ~S ~S ~S" symbol lisp-package package-name)) when package-name - do (let* ((movitz-package (ensure-package package-name lisp-package))) + do (let* ((movitz-package (ensure-package package-name lisp-package symbol))) (setf (movitz-symbol-package (movitz-read symbol)) (movitz-read movitz-package)))) movitz-packages))))

1 0

[movitz-cvs] CVS update: movitz/environment.lisp
by ffjeld＠common-lisp.net 09 Dec '04

09 Dec '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29741 Modified Files: environment.lisp Log Message: minor edits. Date: Thu Dec 9 15:03:30 2004 Author: ffjeld Index: movitz/environment.lisp diff -u movitz/environment.lisp:1.9 movitz/environment.lisp:1.10 --- movitz/environment.lisp:1.9 Mon Oct 11 15:46:25 2004 +++ movitz/environment.lisp Thu Dec 9 15:03:28 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 3 11:40:15 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: environment.lisp,v 1.9 2004/10/11 13:46:25 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.10 2004/12/09 14:03:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -248,10 +248,10 @@ ;;; (warn "..with body ~W" macro-function) (let ((expansion (funcall macro-function form environment))) (cond - #+ignore ((member (if (atom form) form (car form)) - '(<= <=%2op <=%3op) :test #'string=) - (warn "Expanded ~S to ~S" form expansion) - expansion) +;; ((member (if (atom form) form (car form)) +;; '(do) :test #'string=) +;; (warn "Expanded ~S to ~S" form expansion) +;; expansion) (t ;; (warn "Expanded macro named ~A." (if (atom form) form (car form))) expansion))))) @@ -424,7 +424,7 @@ (environment nil) (recurse-p t)) (loop for env = (or environment *movitz-global-environment*) - then (and recurse-p (movitz-environment-uplink env)) + then (when recurse-p (movitz-environment-uplink env)) for plist = (and env (getf (movitz-environment-plists env) symbol)) while env do (let ((val (getf plist indicator '#0=#:not-found)))

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 09 Dec '04

09 Dec '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv28313 Modified Files: compiler.lisp Log Message: Added *compiler-verbose-p* Date: Thu Dec 9 14:36:47 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.117 movitz/compiler.lisp:1.118 --- movitz/compiler.lisp:1.117 Wed Nov 24 11:02:42 2004 +++ movitz/compiler.lisp Thu Dec 9 14:36:46 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.117 2004/11/24 10:02:42 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.118 2004/12/09 13:36:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -17,6 +17,8 @@ (defvar *warn-function-change-p* t "Emit a warning whenever a named function's code-vector changes size.") +(defvar *compiler-verbose-p* nil) + (defvar *compiler-do-optimize* t "Apply the peephole optimizer to function code.") @@ -1334,7 +1336,7 @@ :declaration-context :funobj)) (file-code (with-compilation-unit () - (add-bindings-from-lambda-list () function-env) + (add-bindings-from-lambda-list () function-env) (with-open-file (stream path :direction :input) (setf (funobj-env funobj) funobj-env) (loop for form = (with-movitz-syntax () @@ -1346,7 +1348,12 @@ (cond ((symbolp form) form) ((symbolp (car form)) (car form)))) - #+lispworks-personal-edition (hcl:mark-and-sweep 2) + (when *compiler-verbose-p* + (format *query-io* "~&Movitz Compiling ~S..~%" + (cond + ((symbolp form) form) + ((symbolp (car form)) + (xsubseq form 0 2))))) (compiler-call #'compile-form :form form :funobj funobj

1 0

[movitz-cvs] CVS update: movitz/eval.lisp
by ffjeld＠common-lisp.net 09 Dec '04

09 Dec '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv27587 Modified Files: eval.lisp Log Message: Add rule for evaluation of keywords. Date: Thu Dec 9 14:27:29 2004 Author: ffjeld Index: movitz/eval.lisp diff -u movitz/eval.lisp:1.8 movitz/eval.lisp:1.9 --- movitz/eval.lisp:1.8 Mon Oct 11 15:46:56 2004 +++ movitz/eval.lisp Thu Dec 9 14:27:28 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 2 17:45:05 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: eval.lisp,v 1.8 2004/10/11 13:46:56 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.9 2004/12/09 13:27:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -111,6 +111,8 @@ "3.1.2.1.1 Symbols as Forms" (declare (ignore top-level-p)) (cond + ((keywordp form) + (eval-self-evaluating form env top-level-p)) ((typep (movitz-binding form env) 'constant-object-binding) (translate-program (movitz-print (constant-object (movitz-binding form env))) :cl :muerte.cl))

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/keyboard.lisp
by ffjeld＠common-lisp.net 08 Dec '04

08 Dec '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv19471 Modified Files: keyboard.lisp Log Message: Say #\escape rather than #\esc, since that seems to be more generally acceptable. Date: Thu Dec 9 00:40:24 2004 Author: ffjeld Index: movitz/losp/x86-pc/keyboard.lisp diff -u movitz/losp/x86-pc/keyboard.lisp:1.4 movitz/losp/x86-pc/keyboard.lisp:1.5 --- movitz/losp/x86-pc/keyboard.lisp:1.4 Wed Nov 24 17:20:14 2004 +++ movitz/losp/x86-pc/keyboard.lisp Thu Dec 9 00:40:24 2004 @@ -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.4 2004/11/24 16:20:14 ffjeld Exp $ +;;;; $Id: keyboard.lisp,v 1.5 2004/12/08 23:40:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -42,14 +42,14 @@ nil nil nil nil nil :pause nil nil)) ; #x40 (defparameter *scan-codes* - #(#\null #\esc #\1 #\2 #\3 #\4 #\5 #\6 ; #x00 + #(#\null #\escape #\1 #\2 #\3 #\4 #\5 #\6 ; #x00 #\7 #\8 #\9 #\0 #\- #\= #\backspace #\tab ; #x08 #\q #\w #\e #\r #\t #\y #\u #\i ; #x10 #\o #\p #\[ #\] #\newline :ctrl-left #\a #\s ; #x18 #\d #\f #\g #\h #\j #\k #\l #\; ; #x20 #\' #\` :shift-left #\\ #\z #\x #\c #\v ; #x28 - #\b #\n #\m #\, #\. #\/ :shift-right #\esc ; #x30 + #\b #\n #\m #\, #\. #\/ :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 @@ -74,7 +74,7 @@ nil nil nil nil nil nil nil :home ; #xc0 :up :page-up nil :left nil :right nil :end ; #xc8 - :down :page-down :insert #\delete nil nil nil nil ; #xd0 + :down :page-down :insert nil #+ignore #\delete nil nil nil nil nil ; #xd0 :alt-right nil nil nil :win :menu nil nil)) ; #xd8 (defun lowlevel-event-p ()

1 0

[movitz-cvs] CVS update: movitz/losp/lib/net/tftp.lisp
by ffjeld＠common-lisp.net 08 Dec '04

08 Dec '04

Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv19455 Modified Files: tftp.lisp Log Message: Say #\escape rather than #\esc, since that seems to be more generally acceptable. Date: Thu Dec 9 00:40:15 2004 Author: ffjeld Index: movitz/losp/lib/net/tftp.lisp diff -u movitz/losp/lib/net/tftp.lisp:1.3 movitz/losp/lib/net/tftp.lisp:1.4 --- movitz/losp/lib/net/tftp.lisp:1.3 Thu Nov 25 03:09:55 2004 +++ movitz/losp/lib/net/tftp.lisp Thu Dec 9 00:40:15 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Oct 6 12:42:51 2004 ;;;; -;;;; $Id: tftp.lisp,v 1.3 2004/11/25 02:09:55 ffjeld Exp $ +;;;; $Id: tftp.lisp,v 1.4 2004/12/08 23:40:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -56,14 +56,14 @@ (tftp/ethernet-write :129.242.16.151 file-name data :mac (polling-arp :129.242.16.1 (lambda () - (eql #\esc (muerte.x86-pc.keyboard:poll-char))))))) + (eql #\space (muerte.x86-pc.keyboard:poll-char))))))) (defun tftp/ethernet-write (ip file-name data-vector &key (mode "octet") mac quiet (timeout 2) (data-length (length data-vector)) (breaker (lambda () - (eql #\esc (muerte.x86-pc.keyboard:poll-char))))) + (eql #\space (muerte.x86-pc.keyboard:poll-char))))) "TFTP write data-vector to file-name on host ip using *ip4-nic*. The host's MAC is looked up by ARP unless provided." (let ((speak (if quiet nil *query-io*))

1 0

[movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp
by ffjeld＠common-lisp.net 08 Dec '04

08 Dec '04

Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv19437 Modified Files: ip4.lisp Log Message: Say #\escape rather than #\esc, since that seems to be more generally acceptable. Date: Thu Dec 9 00:40:03 2004 Author: ffjeld Index: movitz/losp/lib/net/ip4.lisp diff -u movitz/losp/lib/net/ip4.lisp:1.15 movitz/losp/lib/net/ip4.lisp:1.16 --- movitz/losp/lib/net/ip4.lisp:1.15 Thu Nov 25 16:06:02 2004 +++ movitz/losp/lib/net/ip4.lisp Thu Dec 9 00:40:03 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 30 13:52:57 2003 ;;;; -;;;; $Id: ip4.lisp,v 1.15 2004/11/25 15:06:02 ffjeld Exp $ +;;;; $Id: ip4.lisp,v 1.16 2004/12/08 23:40:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -493,7 +493,7 @@ (setf *ip4-router* (ip4-address :129.242.16.1))) ;; This is to announce our presence on the LAN.. (assert (polling-arp *ip4-router* (lambda () - (eql #\esc (muerte.x86-pc.keyboard:poll-char)))) + (eql #\space (muerte.x86-pc.keyboard:poll-char)))) () "Unable to resolve ~/ip4:pprint-ip4/ by ARP." *ip4-router*) (values *ip4-nic* *ip4-ip*)) @@ -508,11 +508,11 @@ *ip4-router* (polling-arp *ip4-router* (lambda () - (eql #\esc (muerte.x86-pc.keyboard:poll-char)))))) + (eql #\space (muerte.x86-pc.keyboard:poll-char)))))) (loop (case (muerte.x86-pc.keyboard:poll-char) ((nil)) - ((#\esc) (break "You broke ip4!")) + ((#\space) (break "You broke ip4!")) (t (return (values)))) (let ((packet (and (packet-available-p ethernet) (receive ethernet))))

1 0

[movitz-cvs] CVS update: movitz/losp/los0-gc.lisp
by ffjeld＠common-lisp.net 08 Dec '04

08 Dec '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv19409 Modified Files: los0-gc.lisp Log Message: Say #\escape rather than #\esc, since that seems to be more generally acceptable. Date: Thu Dec 9 00:39:51 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.44 movitz/losp/los0-gc.lisp:1.45 --- movitz/losp/los0-gc.lisp:1.44 Fri Nov 26 15:59:18 2004 +++ movitz/losp/los0-gc.lisp Thu Dec 9 00:39:51 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.44 2004/11/26 14:59:18 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.45 2004/12/08 23:39:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -234,7 +234,7 @@ (break "GC break.") (loop ; This is a nice opportunity to poll the keyboard.. (case (muerte.x86-pc.keyboard:poll-char) - ((#\esc) + ((#\escape) (break "Los0 GC keyboard poll.")) ((nil) (return))))))))) @@ -310,8 +310,8 @@ (values)))) -(defparameter *x* #4000()) ; Have this in static space. -(defparameter *xx* #4000()) ; Have this in static space. +(defparameter *x* #4000(nil)) ; Have this in static space. +(defparameter *xx* #4000(nil)) ; Have this in static space. (defun stop-and-copy (&optional evacuator)

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/pci.lisp
by ffjeld＠common-lisp.net 30 Nov '04

30 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv32022 Modified Files: pci.lisp Log Message: Changed pci-far-call a bit. Date: Tue Nov 30 15:16:57 2004 Author: ffjeld Index: movitz/losp/x86-pc/pci.lisp diff -u movitz/losp/x86-pc/pci.lisp:1.7 movitz/losp/x86-pc/pci.lisp:1.8 --- movitz/losp/x86-pc/pci.lisp:1.7 Fri Nov 26 01:02:39 2004 +++ movitz/losp/x86-pc/pci.lisp Tue Nov 30 15:16:57 2004 @@ -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.7 2004/11/26 00:02:39 ffjeld Exp $ +;;;; $Id: pci.lisp,v 1.8 2004/11/30 14:16:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -55,7 +55,7 @@ (defun pci-far-call (address &key (cs 8) (eax 0) (ebx 0) (ecx 0) (edx 0) (esi 0) (edi 0)) "Make a 'far call' to cs:address with the provided values for eax and ebx. -Returns the values of registers EAX, EBX, ECX, and EDX, and status of CF. +Returns the boolean status of CF, and the values of registers EAX, EBX, ECX, and EDX. The stack discipline is broken during this call, so we disable interrupts in a somewhat feeble attempt to avoid trouble." (check-type address (unsigned-byte 32)) @@ -94,26 +94,27 @@ (:call-segment (:esp)) (:leal (:esp 8) :esp) ; Skip cs:address (:popl :edi) ; First of all, restore EDI! - (:locally (:movl :edi (:edi (:edi-offset values) 8))) + (:locally (:movl :edi (:edi (:edi-offset scratch2)))) (:jnc 'cf=0) (:locally (:pushl (:edi (:edi-offset t-symbol)))) - (:locally (:popl (:edi (:edi-offset values) 8))) + (:locally (:popl (:edi (:edi-offset scratch2)))) cf=0 (:pushl :eax) (:pushl :ebx) (:pushl :edx) (:locally (:movl 3 (:edi (:edi-offset num-values)))) (:call-local-pf box-u32-ecx) ; ECX - (:locally (:movl :eax (:edi (:edi-offset values) 0))) + (:locally (:movl :eax (:edi (:edi-offset values) 4))) (:popl :ecx) ; EDX (:call-local-pf box-u32-ecx) - (:locally (:movl :eax (:edi (:edi-offset values) 4))) + (:locally (:movl :eax (:edi (:edi-offset values) 8))) (:popl :ecx) ; EBX (:call-local-pf box-u32-ecx) - (:locally (:movl :eax (:edi (:edi-offset scratch1)))) + (:locally (:movl :eax (:edi (:edi-offset values) 0))) (:popl :ecx) ; EAX (:call-local-pf box-u32-ecx) - (:locally (:movl (:edi (:edi-offset scratch1)) :ebx)) + (:movl :eax :ebx) + (:locally (:movl (:edi (:edi-offset scratch2)) :eax)) (:movl 5 :ecx) (:movl (:ebp -4) :esi) (:stc) @@ -124,27 +125,28 @@ (defun find-bios32-pci () (let ((bios32-base (find-bios32-base))) (assert bios32-base "No bios32 found.") - (multiple-value-bind (eax ebx ecx edx) + (multiple-value-bind (cf eax ebx ecx edx) (pci-far-call (memref-int bios32-base :offset 4) :eax (pci-word "$PCI")) - (declare (ignore ecx)) + (declare (ignore cf ecx)) (ecase (ldb (byte 8 0) eax) (#x80 (error "The PCI bios32 service isn't present.")) (#x81 (error "The PCI bios32 service doesn't exist.")) (#x00 (+ ebx edx)))))) (defun pci-bios-present () - (multiple-value-bind (eax ebx ecx edx cf) + (multiple-value-bind (cf eax ebx ecx edx) (pci-far-call (find-bios32-pci) :eax #xb101) - (values (pci-string edx) - (ldb (byte 8 8) eax) ; AH: Present status - (ldb (byte 8 0) eax) ; AL: Hardware mechanism - (ldb (byte 8 8) ebx) ; BH: Interface Level Major Version - (ldb (byte 8 0) ebx) ; BL: Interface Level Minor Version - (ldb (byte 8 0) ecx)))) ; CL: Number of last PCI bus in the system + (unless cf + (values (pci-string edx) + (ldb (byte 8 8) eax) ; AH: Present status + (ldb (byte 8 0) eax) ; AL: Hardware mechanism + (ldb (byte 8 8) ebx) ; BH: Interface Level Major Version + (ldb (byte 8 0) ebx) ; BL: Interface Level Minor Version + (ldb (byte 8 0) ecx))))) ; CL: Number of last PCI bus in the system (defun find-pci-device (vendor device &optional (index 0)) - (multiple-value-bind (eax ebx ecx edx cf) + (multiple-value-bind (cf eax ebx) (pci-far-call (find-bios32-pci) :eax #xb102 :ecx device @@ -160,12 +162,11 @@ (#x83 :bad-vendor-id)))))) (defun find-pci-class-code (class-code &optional (index 0)) - (multiple-value-bind (eax ebx ecx edx cf) + (multiple-value-bind (cf eax ebx) (pci-far-call (find-bios32-pci) :eax #xb103 :ecx class-code :esi index) - (declare (ignore ecx edx)) (unless cf (values (ldb (byte 8 8) ebx) ; Bus (ldb (byte 5 3) ebx) ; Device @@ -231,36 +232,59 @@ (nth (ldb (byte 8 0) code) sub-class-table)))) (values (car class-table) sub-class sub-class-if))) -(defun pci-bios-read-configuration-word (bus device function register) - (multiple-value-bind (eax ebx ecx edx cf) +(defun pci-bios-config-space (bus device function register command size) + (multiple-value-bind (cf eax ebx ecx) (pci-far-call (find-bios32-pci) - :eax #xb109 + :eax command :ebx (pci-location bus device function) :edi register) - (declare (ignore ebx edx)) + (declare (ignore ebx)) (unless cf - (values (ldb (byte 16 0) ecx) (pci-return-code eax))))) + (values (ldb (byte size 0) ecx) + (pci-return-code eax))))) -(defun pci-bios-read-configuration-dword (bus device function register) - (multiple-value-bind (eax ebx ecx edx cf) +(defun (setf pci-bios-config-space) (value bus device function register command size) + (declare (ignore size)) + (multiple-value-bind (cf eax) (pci-far-call (find-bios32-pci) - :eax #xb10a + :eax command :ebx (pci-location bus device function) + :ecx value :edi register) - (declare (ignore ebx edx)) (unless cf - (values ecx (pci-return-code eax))))) + (pci-return-code eax)))) + +(defun pci-bios-config-space-dword (bus device function register) + (pci-bios-config-space bus device function register #xb10a 32)) + +(defun pci-bios-config-space-word (bus device function register) + (pci-bios-config-space bus device function register #xb109 16)) + +(defun pci-bios-config-space-byte (bus device function register) + (pci-bios-config-space bus device function register #xb108 8)) + +(defun (setf pci-bios-config-space-dword) (value bus device function register) + (setf (pci-bios-config-space bus device function register #xb10d 32) + value)) + +(defun (setf pci-bios-config-space-word) (value bus device function register) + (setf (pci-bios-config-space bus device function register #xb10c 16) + value)) + +(defun (setf pci-bios-config-space-byte) (value bus device function register) + (setf (pci-bios-config-space bus device function register #xb10b 8) + value)) (defun scan-pci-bus (bus) (loop for device from 0 to 31 do (multiple-value-bind (vendor-id return-code) - (pci-bios-read-configuration-word bus device 0 0) + (pci-bios-config-space-word bus device 0 0) (when (and vendor-id (not (= vendor-id #xffff)) (eq :successful return-code)) - (let ((device-id (pci-bios-read-configuration-word bus device 0 2)) - (status (pci-bios-read-configuration-word bus device 0 6)) - (class-rev (pci-bios-read-configuration-dword bus device 0 8))) + (let ((device-id (pci-bios-config-space-word bus device 0 2)) + (status (pci-bios-config-space-word bus device 0 6)) + (class-rev (pci-bios-config-space-dword bus device 0 8))) (format *query-io* "~&~D: Vendor #x~X, ID #x~X, Class #x~X, Rev. ~D, Status #x~X.~%" device vendor-id device-id

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/ne2k.lisp
by ffjeld＠common-lisp.net 30 Nov '04

30 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv31991 Modified Files: ne2k.lisp Log Message: This makes Qemu work. Date: Tue Nov 30 15:16:40 2004 Author: ffjeld Index: movitz/losp/x86-pc/ne2k.lisp diff -u movitz/losp/x86-pc/ne2k.lisp:1.13 movitz/losp/x86-pc/ne2k.lisp:1.14 --- movitz/losp/x86-pc/ne2k.lisp:1.13 Wed Nov 24 17:20:30 2004 +++ movitz/losp/x86-pc/ne2k.lisp Tue Nov 30 15:16:38 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 17 15:16:00 2002 ;;;; -;;;; $Id: ne2k.lisp,v 1.13 2004/11/24 16:20:30 ffjeld Exp $ +;;;; $Id: ne2k.lisp,v 1.14 2004/11/30 14:16:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -217,6 +217,7 @@ (%io-port-write-succession (asic-io-base device) packet 2 start end :16-bit)) (setf (io-register8x2 dp8390 ($page0-write tbcr1) ($page0-write tbcr0)) packet-length (dp8390 ($page0-write cr)) ($command transmit start abort-complete)) + #+ignore (loop while (= (dp8390 ($page0-read cr)) ($command start transmit abort-complete))))) nil)

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