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

[movitz-cvs] CVS update: movitz/losp/x86-pc/pci.lisp
by ffjeld＠common-lisp.net 14 Aug '05

14 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv24313 Modified Files: pci.lisp Log Message: Added pci-device-address-maps. Date: Sun Aug 14 14:15:05 2005 Author: ffjeld Index: movitz/losp/x86-pc/pci.lisp diff -u movitz/losp/x86-pc/pci.lisp:1.10 movitz/losp/x86-pc/pci.lisp:1.11 --- movitz/losp/x86-pc/pci.lisp:1.10 Fri Aug 12 08:34:35 2005 +++ movitz/losp/x86-pc/pci.lisp Sun Aug 14 14:15:04 2005 @@ -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.10 2005/08/12 06:34:35 ffjeld Exp $ +;;;; $Id: pci.lisp,v 1.11 2005/08/14 12:15:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -281,6 +281,30 @@ (setf (pci-bios-config-space bus device function register #xb10b 8) value)) + +(defmacro pci-config (register) + (cdr (or (assoc register + '((:interrupt-line . #x3c) + (:interrupt-pin . #x3d) + (:base-addr . #x10) + (:memspace . #x00) + (:iospace . #x01) + (:type . #x06) + (:memspace64 . #x01))) + (error "Unknown pci-config register: ~S" register)))) + +(defun pci-device-address-maps (bus device function) + (loop for i upfrom (pci-config :base-addr) by 4 repeat 6 + as base = (pci-bios-config-space-dword bus device function i) + unless (= 0 base) collect + (cond + ((logbitp 0 base) + (cons :io (logand base -4))) + ((= 1 (ldb (byte 2 1) base)) + (cons :mem64 (logand base -16))) + (t + (cons :mem32 (logand base -16)))))) + (defun scan-pci-bus (bus) (loop for device from 0 to 31 do (multiple-value-bind (vendor-id return-code) @@ -298,5 +322,6 @@ (ldb (byte 8 0) class-rev) status) (format *query-io* " Class:~{ ~@[~A~]~}" - (multiple-value-list (pci-class (ldb (byte 24 8) class-rev)))))))) - (values)) \ No newline at end of file + (multiple-value-list (pci-class (ldb (byte 24 8) class-rev)))) + (format *query-io* "~S" (pci-device-address-maps bus device 0)))))) + (values))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/print.lisp
by ffjeld＠common-lisp.net 14 Aug '05

14 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24206 Modified Files: print.lisp Log Message: Add #\_ as a 'safe' character. Date: Sun Aug 14 14:13:51 2005 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.19 movitz/losp/muerte/print.lisp:1.20 --- movitz/losp/muerte/print.lisp:1.19 Wed May 4 10:00:39 2005 +++ movitz/losp/muerte/print.lisp Sun Aug 14 14:13:51 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.19 2005/05/04 08:00:39 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.20 2005/08/14 12:13:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -258,7 +258,7 @@ (every (lambda (c) (or (upper-case-p c) (member c '(#\+ #\- #\% #\$ #\* #\@ #\. #\& - #\/ #\< #\> #\=)) + #\/ #\< #\> #\= #\_)) (digit-char-p c))) name) (not (every (lambda (c)

1 0

[movitz-cvs] CVS update: movitz/losp/lib/net/ethernet.lisp
by ffjeld＠common-lisp.net 14 Aug '05

14 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv24190 Modified Files: ethernet.lisp Log Message: Add a print-object method for ethernet devices. Date: Sun Aug 14 14:13:27 2005 Author: ffjeld Index: movitz/losp/lib/net/ethernet.lisp diff -u movitz/losp/lib/net/ethernet.lisp:1.8 movitz/losp/lib/net/ethernet.lisp:1.9 --- movitz/losp/lib/net/ethernet.lisp:1.8 Sun May 22 00:37:21 2005 +++ movitz/losp/lib/net/ethernet.lisp Sun Aug 14 14:13:27 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 17 15:25:31 2002 ;;;; -;;;; $Id: ethernet.lisp,v 1.8 2005/05/21 22:37:21 ffjeld Exp $ +;;;; $Id: ethernet.lisp,v 1.9 2005/08/14 12:13:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -189,6 +189,12 @@ :initarg :promiscuous-p :initform nil :accessor promiscuous-p))) + +(defmethod print-object ((x ethernet-device) s) + (print-unreadable-object (x s :type t :identity t) + (when (slot-boundp x 'mac-address) + (pprint-mac s (mac-address x))))) + (defgeneric transmit (device packet &optional start end)) (defgeneric receive (device &optional packet start))

1 0

[movitz-cvs] CVS update: movitz/environment.lisp
by ffjeld＠common-lisp.net 14 Aug '05

14 Aug '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24167 Modified Files: environment.lisp Log Message: sync Date: Sun Aug 14 14:13:07 2005 Author: ffjeld Index: movitz/environment.lisp diff -u movitz/environment.lisp:1.12 movitz/environment.lisp:1.13 --- movitz/environment.lisp:1.12 Tue Jan 4 12:35:25 2005 +++ movitz/environment.lisp Sun Aug 14 14:13:07 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 3 11:40:15 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: environment.lisp,v 1.12 2005/01/04 11:35:25 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.13 2005/08/14 12:13:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -292,12 +292,14 @@ ;;; (warn "..with body ~W" macro-function) (let ((expansion (funcall macro-function form environment))) (cond -;; ((member (if (atom form) form (car form)) -;; '(do) :test #'string=) -;; (warn "Expanded ~S to ~S" form expansion) -;; expansion) + #+ignore ((member (if (atom form) form (car form)) + '(setf pcnet-reg) :test #'string=) + (warn "Expanded ~S to ~S" form expansion) + expansion) (t - ;; (warn "Expanded macro named ~A." (if (atom form) form (car form))) + #+ignore (warn "Expanded ~A:~%~S." + (if (atom form) form (car form)) + expansion) expansion))))) (defun movitz-macroexpand-1 (form &optional env)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp
by ffjeld＠common-lisp.net 14 Aug '05

14 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24032 Modified Files: typep.lisp Log Message: Fixed error message for etypecase. Added non-compiled (typep x '(array ..)). Tweaked coerce to be somewhat more general. Date: Sun Aug 14 14:04:06 2005 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.45 movitz/losp/muerte/typep.lisp:1.46 --- movitz/losp/muerte/typep.lisp:1.45 Fri Jun 10 00:19:10 2005 +++ movitz/losp/muerte/typep.lisp Sun Aug 14 14:04:05 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.45 2005/06/09 22:19:10 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.46 2005/08/14 12:04:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -42,9 +42,7 @@ (t (error "~S fell through an etypecase where the legal types were ~S." ,keyform ',(loop for c in clauses - if (listp (car c)) - append (car c) - else collect (car c)))))) + collect (car c)))))) (define-compile-time-variable *simple-typespecs* ;; map symbol typespecs to typep-functions. @@ -492,6 +490,17 @@ ',fname)) (defun ,fname ,lambda ,@body)))) +(defun expand-type (type-specifier) + (typecase type-specifier + (symbol + (let ((typep-function (gethash type-specifier *derived-typespecs*))) + (when typep-function + (funcall typep-function)))) + (cons + (let ((typep-function (gethash (car type-specifier) *derived-typespecs*))) + (when typep-function + (apply typep-function (cdr type-specifier))))))) + (defun typep (object type-specifier) (block nil (typecase type-specifier @@ -568,7 +577,26 @@ (or (eq '* cdr) (typep (cdr x) cdr)))) (deftype vector (&optional (element-type '*) (size '*)) - `(simple-array ,element-type (,size))) + (if (eq size '*) + `(array ,element-type 1) + `(array ,element-type (,size)))) + +(define-typep array (x &optional (element-type '*) (dimension-spec '*)) + (and (typep x 'array) + (or (eq element-type '*) + (do ((xet (array-element-type x)) + (aet element-type (expand-type aet))) + ((eq nil aet) nil) + (when (equal xet aet) (return t)))) + (or (eq dimension-spec '*) + (if (integerp dimension-spec) + (= dimension-spec (array-rank x)) + (and (= (length dimension-spec) (array-rank x)) + (every (lambda (xdim adim) + (or (eq xdim '*) (= xdim adim))) + dimension-spec + (array-dimensions x))))))) + (define-simple-typep (atom atom) (x) (typep x 'atom)) @@ -669,14 +697,22 @@ (defun coerce (object result-type) "=> result" - (cond - ((typep object result-type) - object) - ((and (eq result-type 'list) - (typep object 'sequence)) - (map 'list #'identity object)) - ((and (typep object 'sequence) - (member result-type '(vector array))) - (make-array (length object) :initial-contents object)) - (t (error "Don't know how to coerce ~S to ~S." object result-type)))) + (flet ((c (object result-type actual-type) + (cond + ((typep object result-type) + object) + ((member result-type '(list array vector)) + (map result-type #'identity object)) + ((and (consp result-type) + (eq (car result-type) 'vector)) + (let* ((p (cdr result-type)) + (et (if p (pop p) t)) + (size (if p (pop p) nil))) + (make-array (or size (length object)) + :initial-contents object + :element-type et))) + ((not (eq nil result-type)) + (c object (expand-type result-type) actual-type)) + (t (error "Don't know how to coerce ~S to ~S." object actual-type))))) + (c object result-type result-type)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp
by ffjeld＠common-lisp.net 14 Aug '05

14 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv22106 Modified Files: arrays.lisp Log Message: Fixed array-dimensions, added array-rank. Date: Sun Aug 14 13:35:52 2005 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.53 movitz/losp/muerte/arrays.lisp:1.54 --- movitz/losp/muerte/arrays.lisp:1.53 Sat Jun 11 02:01:56 2005 +++ movitz/losp/muerte/arrays.lisp Sun Aug 14 13:35:52 2005 @@ -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.53 2005/06/11 00:01:56 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.54 2005/08/14 11:35:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -134,8 +134,17 @@ (memref array (movitz-type-slot-offset 'movitz-basic-vector 'num-elements))))) (defun array-dimensions (array) + (let (r) + (dotimes (d (array-rank array)) + (push (array-dimension array d) r)) + (nreverse r))) + +(defun array-rank (array) (etypecase array - (vector 1))) + (indirect-vector + 1) + ((simple-array * 1) + 1))) (defun shrink-vector (vector new-size) (check-type vector vector)

1 0

[movitz-cvs] CVS update: ia-x86/operands.lisp
by ffjeld＠common-lisp.net 13 Aug '05

13 Aug '05

Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv28778 Modified Files: operands.lisp Log Message: Don't sign-extend already sign-extended displacement. Date: Sat Aug 13 22:31:51 2005 Author: ffjeld Index: ia-x86/operands.lisp diff -u ia-x86/operands.lisp:1.5 ia-x86/operands.lisp:1.6 --- ia-x86/operands.lisp:1.5 Thu Sep 2 11:01:44 2004 +++ ia-x86/operands.lisp Sat Aug 13 22:31:51 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 20012000, 2002-2004, +;;;; Copyright (C) 20012000, 2002-2005, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: operands.lisp @@ -9,7 +9,7 @@ ;;;; Created at: Wed Feb 16 14:02:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: operands.lisp,v 1.5 2004/09/02 09:01:44 ffjeld Exp $ +;;;; $Id: operands.lisp,v 1.6 2005/08/13 20:31:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -945,7 +945,7 @@ operand (setf register (decode-set (find-register-decode-set 'r/m32-01) r/m) - offset (realpart (sign-extend-complex displacement))))) + offset (realpart displacement)))) (values operand)) (defmethod operand-encode ((operand operand-indirect-register) @@ -1687,7 +1687,7 @@ (with-slots (offset) operand (setf offset - (realpart (sign-extend-complex (slot-value instr-symbolic 'displacement))))) + (realpart (slot-value instr-symbolic 'displacement)))) (values operand)) (defmethod operand-encode ((operand operand-rel-pointer)

1 0

[movitz-cvs] CVS update: ia-x86/codec.lisp
by ffjeld＠common-lisp.net 13 Aug '05

13 Aug '05

Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv27770 Modified Files: codec.lisp Log Message: Sign-extend the displacement part of an instruction when decoding it. Date: Sat Aug 13 22:24:05 2005 Author: ffjeld Index: ia-x86/codec.lisp diff -u ia-x86/codec.lisp:1.6 ia-x86/codec.lisp:1.7 --- ia-x86/codec.lisp:1.6 Thu Sep 2 11:01:19 2004 +++ ia-x86/codec.lisp Sat Aug 13 22:24:04 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2000, 2001, 2002, 2004, +;;;; Copyright (C) 2000, 2001, 2002, 2004-2005, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: codec.lisp @@ -9,7 +9,7 @@ ;;;; Created at: Thu May 4 15:16:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: codec.lisp,v 1.6 2004/09/02 09:01:19 ffjeld Exp $ +;;;; $Id: codec.lisp,v 1.7 2005/08/13 20:24:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -701,11 +701,12 @@ (incf byte-pos (template-instr-immediate-numo template)) ;; displacement (setf (instr-symbolic-displacement is) - (complex (change-endian (ldb (byte (* 8 (template-instr-displacement-numo template)) - (* 8 byte-pos)) - datum) - (template-instr-displacement-numo template)) - (template-instr-displacement-numo template))) + (sign-extend-complex + (complex (change-endian (ldb (byte (* 8 (template-instr-displacement-numo template)) + (* 8 byte-pos)) + datum) + (template-instr-displacement-numo template)) + (template-instr-displacement-numo template)))) (incf byte-pos (template-instr-displacement-numo template)) ;; SIB (when (template-instr-sib-p template)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/io-port.lisp
by ffjeld＠common-lisp.net 12 Aug '05

12 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7409 Modified Files: io-port.lisp Log Message: Added (setf (io-port :unsigned-byte32)). Date: Sat Aug 13 00:55:43 2005 Author: ffjeld Index: movitz/losp/muerte/io-port.lisp diff -u movitz/losp/muerte/io-port.lisp:1.15 movitz/losp/muerte/io-port.lisp:1.16 --- movitz/losp/muerte/io-port.lisp:1.15 Sat Aug 13 00:50:22 2005 +++ movitz/losp/muerte/io-port.lisp Sat Aug 13 00:55:43 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Mar 21 22:14:08 2001 ;;;; -;;;; $Id: io-port.lisp,v 1.15 2005/08/12 22:50:22 ffjeld Exp $ +;;;; $Id: io-port.lisp,v 1.16 2005/08/12 22:55:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -169,6 +169,19 @@ (:movl :edi :eax) (:cld)) ,value-var)) + (:unsigned-byte32 + `(let ((,value-var ,value) + (,port-var ,port)) + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:load-lexical (:lexical-binding ,port-var) :edx) + (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-ecx) + (:std) + (:shrl ,movitz::+movitz-fixnum-shift+ :edx) + (:movl :ecx :eax) + (:outl :eax :dx) + (:movl :edi :edx) + (:movl :edi :eax) + (:cld)))) (:character `(let ((,value-var ,value) (,port-var ,port)) @@ -190,7 +203,9 @@ (:unsigned-byte8 (setf (io-port port :unsigned-byte8) value)) (:unsigned-byte16 - (setf (io-port port :unsigned-byte8) value)) + (setf (io-port port :unsigned-byte16) value)) + (:unsigned-byte32 + (setf (io-port port :unsigned-byte32) value)) (:character (setf (io-port port :character) value))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/io-port.lisp
by ffjeld＠common-lisp.net 12 Aug '05

12 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7371 Modified Files: io-port.lisp Log Message: Added (io-port :unsigned-byte32). Date: Sat Aug 13 00:50:23 2005 Author: ffjeld Index: movitz/losp/muerte/io-port.lisp diff -u movitz/losp/muerte/io-port.lisp:1.14 movitz/losp/muerte/io-port.lisp:1.15 --- movitz/losp/muerte/io-port.lisp:1.14 Sat Aug 13 00:44:10 2005 +++ movitz/losp/muerte/io-port.lisp Sat Aug 13 00:50:22 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Mar 21 22:14:08 2001 ;;;; -;;;; $Id: io-port.lisp,v 1.14 2005/08/12 22:44:10 ffjeld Exp $ +;;;; $Id: io-port.lisp,v 1.15 2005/08/12 22:50:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -46,6 +46,16 @@ (:shll ,movitz:+movitz-fixnum-shift+ :eax) (:movl :edi :edx) (:cld))) + (:unsigned-byte32 + `(with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-form (:result-mode :edx) ,port) + (:std) + (:shrl ,movitz::+movitz-fixnum-shift+ :edx) + (:inl :dx :eax) + (:movl :eax :ecx) + (:movl :edi :eax) + (:movl :edi :edx) + (:cld))) (:character `(with-inline-assembly (:returns :eax) (:compile-form (:result-mode :edx) ,port) @@ -64,6 +74,8 @@ (io-port port :unsigned-byte8)) (:unsigned-byte16 (io-port port :unsigned-byte16)) + (:unsigned-byte32 + (io-port port :unsigned-byte32)) (:character (io-port port :character))))

1 0