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

[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-serv19115 Modified Files: typep.lisp Log Message: *** empty log message *** Date: Sun Aug 14 20:52:53 2005 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.47 movitz/losp/muerte/typep.lisp:1.48 --- movitz/losp/muerte/typep.lisp:1.47 Sun Aug 14 14:26:10 2005 +++ movitz/losp/muerte/typep.lisp Sun Aug 14 20:52:53 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.47 2005/08/14 12:26:10 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.48 2005/08/14 18:52:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -589,7 +589,7 @@ ((eq nil aet) nil) (when (equal xet aet) (return t)))) (or (eq dimension-spec '*) - (if (integerp dimension-spec) + (if (typep dimension-spec 'integer) (= dimension-spec (array-rank x)) (and (= (length dimension-spec) (array-rank x)) (every (lambda (xdim adim)

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-serv19083 Modified Files: ethernet.lisp Log Message: Add deftype mac-address as (vector (unsigned-byte 8) 6) Date: Sun Aug 14 20:52:40 2005 Author: ffjeld Index: movitz/losp/lib/net/ethernet.lisp diff -u movitz/losp/lib/net/ethernet.lisp:1.9 movitz/losp/lib/net/ethernet.lisp:1.10 --- movitz/losp/lib/net/ethernet.lisp:1.9 Sun Aug 14 14:13:27 2005 +++ movitz/losp/lib/net/ethernet.lisp Sun Aug 14 20:52:39 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.9 2005/08/14 12:13:27 ffjeld Exp $ +;;;; $Id: ethernet.lisp,v 1.10 2005/08/14 18:52:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -170,6 +170,8 @@ (ether-type packet start) type) packet) +(deftype mac-address () + '(vector (unsigned-byte 8) 6)) (defclass ethernet-device () ((mac-address

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette.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-serv19047 Modified Files: los-closette.lisp Log Message: Fixed cut'n'paste-bug that caused specializing (setf slot-value-using-class) not to work. Date: Sun Aug 14 20:50:13 2005 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.33 movitz/losp/muerte/los-closette.lisp:1.34 --- movitz/losp/muerte/los-closette.lisp:1.33 Fri May 6 17:39:44 2005 +++ movitz/losp/muerte/los-closette.lisp Sun Aug 14 20:50:12 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.33 2005/05/06 15:39:44 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.34 2005/08/14 18:50:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1554,7 +1554,7 @@ (or (not *standard-setf-slot-value-using-class*) ; still bootstrapping.. (not (let ((value (car args)) (object (cadr args))) - (gf-nonstandard-specialized-p #'slot-value-using-class + (gf-nonstandard-specialized-p #'(setf slot-value-using-class) (if (typep object 'funcallable-standard-class) *standard-gf-setf-slot-value-using-class* *standard-setf-slot-value-using-class*)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.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-serv10204 Modified Files: basic-macros.lisp Log Message: Removed bogus macro that expanded if in terms of cond. This would i.e. confuse some tree-walking stuff in loop's expander. Date: Sun Aug 14 18:39:39 2005 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.61 movitz/losp/muerte/basic-macros.lisp:1.62 --- movitz/losp/muerte/basic-macros.lisp:1.61 Wed May 4 00:15:38 2005 +++ movitz/losp/muerte/basic-macros.lisp Sun Aug 14 18:39:39 2005 @@ -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.61 2005/05/03 22:15:38 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.62 2005/08/14 16:39:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -106,9 +106,6 @@ (define-compiler-macro cond (&body cond-body) (cons 'compiled-cond cond-body)) - -(defmacro if (test-form then-form &optional else-form) - `(cond (,test-form ,then-form) (t ,else-form))) (define-compiler-macro if (test-form then-form &optional else-form &environment env) (when (and (movitz:movitz-constantp then-form env) (movitz:movitz-constantp else-form 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-serv25376 Modified Files: typep.lisp Log Message: Fixed labels/flet confusion in coerce. Date: Sun Aug 14 14:26:10 2005 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.46 movitz/losp/muerte/typep.lisp:1.47 --- movitz/losp/muerte/typep.lisp:1.46 Sun Aug 14 14:04:05 2005 +++ movitz/losp/muerte/typep.lisp Sun Aug 14 14:26:10 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.46 2005/08/14 12:04:05 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.47 2005/08/14 12:26:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -697,22 +697,23 @@ (defun coerce (object result-type) "=> result" - (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))))) + (labels + ((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/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