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

[movitz-cvs] CVS update: movitz/bochsrc.txt
by Frode Vatvedt Fjeld 21 May '04

21 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv15841 Modified Files: bochsrc.txt Log Message: The layout of heap objects has been changed such that the type-code is now the "first" byte in the object. Date: Fri May 21 05:40:09 2004 Author: ffjeld Index: movitz/bochsrc.txt diff -u movitz/bochsrc.txt:1.1.1.1 movitz/bochsrc.txt:1.2 --- movitz/bochsrc.txt:1.1.1.1 Tue Jan 13 06:04:59 2004 +++ movitz/bochsrc.txt Fri May 21 05:40:09 2004 @@ -36,5 +36,5 @@ error: action=report # debug: action=report -ips: 3000000 +ips: 2000000 # com1: dev=/dev/ptypv

1 0

[movitz-cvs] CVS update: movitz/packages.lisp
by Frode Vatvedt Fjeld 21 May '04

21 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv6114 Modified Files: packages.lisp Log Message: The layout of heap objects has been changed such that the type-code is now the "first" byte in the object. Date: Fri May 21 05:39:42 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.21 movitz/packages.lisp:1.22 --- movitz/packages.lisp:1.21 Wed Apr 21 12:00:25 2004 +++ movitz/packages.lisp Fri May 21 05:39:40 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.21 2004/04/21 16:00:25 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.22 2004/05/21 09:39:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1284,6 +1284,7 @@ #:dump-image #:other-type-byte + #:+other-type-offset+ #:parse-docstring-and-declarations #:global-constant-offset #:tag #:tag-name

1 0

[movitz-cvs] CVS update: movitz/storage-types.lisp
by Frode Vatvedt Fjeld 21 May '04

21 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv3712 Modified Files: storage-types.lisp Log Message: The layout of heap objects has been changed such that the type-code is now the "first" byte in the object. Date: Fri May 21 05:39:30 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.16 movitz/storage-types.lisp:1.17 --- movitz/storage-types.lisp:1.16 Wed Apr 21 12:22:56 2004 +++ movitz/storage-types.lisp Fri May 21 05:39:30 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.16 2004/04/21 16:22:56 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.17 2004/05/21 09:39:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -84,7 +84,6 @@ (defconstant +fixnum-tags+ '(:even-fixnum :odd-fixnum)) (defparameter +scan-skip-word+ #x00000003) - (defun tag (type) (bt:enum-value 'other-type-byte type)) @@ -165,12 +164,14 @@ ;;; Fixnums (eval-when (:compile-toplevel :execute :load-toplevel) -(defconstant +movitz-fixnum-bits+ 30) -(defconstant +movitz-fixnum-shift+ (- 32 +movitz-fixnum-bits+)) -(defconstant +movitz-fixnum-factor+ (expt 2 +movitz-fixnum-shift+)) -(defconstant +movitz-fixnum-zmask+ (1- +movitz-fixnum-factor+)) -(defconstant +movitz-most-positive-fixnum+ (1- (expt 2 (1- +movitz-fixnum-bits+)))) -(defconstant +movitz-most-negative-fixnum+ (- (expt 2 (1- +movitz-fixnum-bits+))))) + (defconstant +movitz-fixnum-bits+ 30) + (defconstant +movitz-fixnum-shift+ (- 32 +movitz-fixnum-bits+)) + (defconstant +movitz-fixnum-factor+ (expt 2 +movitz-fixnum-shift+)) + (defconstant +movitz-fixnum-zmask+ (1- +movitz-fixnum-factor+)) + (defconstant +movitz-most-positive-fixnum+ (1- (expt 2 (1- +movitz-fixnum-bits+)))) + (defconstant +movitz-most-negative-fixnum+ (- (expt 2 (1- +movitz-fixnum-bits+)))) + + (defparameter +other-type-offset+ -6)) (defun fixnum-integer (word) "For a Movitz word, that must be a fixnum, return the corresponding @@ -325,24 +326,7 @@ ;;; movitz-vectors (define-binary-class movitz-vector (movitz-heap-object-other) - ((flags - :accessor movitz-vector-flags - :initarg :flags - :initform nil - :binary-type (define-bitfield movitz-vector-flags (u8) - (((:bits) :fill-pointer-p 2 - :code-vector-p 3 - :std-instance-slots-p 4)))) - (alignment-power - :binary-lisp-type u8 ; align to 2^(high-nibble+3) + low-nibble - :initform 0 - :initarg :alignment-power - :reader movitz-vector-alignment-power) - (num-elements - :binary-type lu16 - :initarg :num-elements - :reader movitz-vector-num-elements) - (type + ((type :binary-type other-type-byte :reader movitz-vector-type :initform :vector) @@ -360,43 +344,60 @@ :binary-type lu16 :initarg :fill-pointer :accessor movitz-vector-fill-pointer) + (flags + :accessor movitz-vector-flags + :initarg :flags + :initform nil + :binary-type (define-bitfield movitz-vector-flags (u8) + (((:bits) :fill-pointer-p 2 + :code-vector-p 3 + :std-instance-slots-p 4)))) + (alignment-power + :binary-lisp-type u8 ; align to 2^(high-nibble+3) + low-nibble + :initform 0 + :initarg :alignment-power + :reader movitz-vector-alignment-power) + (num-elements + :binary-type lu16 + :initarg :num-elements + :reader movitz-vector-num-elements) (data :binary-lisp-type :label) ; data follows physically here (symbolic-data :initarg :symbolic-data :accessor movitz-vector-symbolic-data)) - (:slot-align type -2)) + (:slot-align type #.+other-type-offset+)) (defun vector-type-tag (element-type) (dpb (enum-value 'movitz-vector-element-type element-type) (byte 8 8) (enum-value 'other-type-byte :vector))) -(define-binary-class movitz-new-vector (movitz-heap-object-other) - ((length - :binary-type u32 - :initarg :length - :accessor movitz-simple-vector-length) - (type - :binary-type other-type-byte - :reader movitz-vector-type) - #+ignore - (element-type - :binary-type (define-enum movitz-vector-element-type (u8) - :any-t 0 - :character 1 - :u8 2 - :u16 3 - :u32 4 - :bit 5) - :initarg :element-type - :reader movitz-vector-element-type) - (data - :binary-lisp-type :label) - (symbolic-data - :initarg :symbolic-data - :accessor movitz-vector-symbolic-data)) - (:slot-align type -2)) +;;;(define-binary-class movitz-new-vector (movitz-heap-object-other) +;;; ((length +;;; :binary-type u32 +;;; :initarg :length +;;; :accessor movitz-simple-vector-length) +;;; (type +;;; :binary-type other-type-byte +;;; :reader movitz-vector-type) +;;; #+ignore +;;; (element-type +;;; :binary-type (define-enum movitz-vector-element-type (u8) +;;; :any-t 0 +;;; :character 1 +;;; :u8 2 +;;; :u16 3 +;;; :u32 4 +;;; :bit 5) +;;; :initarg :element-type +;;; :reader movitz-vector-element-type) +;;; (data +;;; :binary-lisp-type :label) +;;; (symbolic-data +;;; :initarg :symbolic-data +;;; :accessor movitz-vector-symbolic-data)) +;;; (:slot-align type #.+other-type-offset+)) (defun movitz-type-word-size (type) (truncate (sizeof (intern (symbol-name type) :movitz)) 4)) @@ -745,14 +746,7 @@ ;;; Compiled funobj (define-binary-class movitz-funobj (movitz-heap-object-other) - ((code-vector - :binary-type code-vector-word - :initform 'muerte::no-code-vector - :initarg :code-vector - :map-binary-write 'movitz-intern-code-vector - :map-binary-read-delayed 'movitz-word-code-vector - :accessor movitz-funobj-code-vector) - (type + ((type :binary-type other-type-byte :initform :funobj) (funobj-type @@ -767,6 +761,13 @@ ;; Bit 5: The code-vector's uses-stack-frame-p. :binary-type 'lu16 :initform 0) + (code-vector + :binary-type code-vector-word + :initform 'muerte::no-code-vector + :initarg :code-vector + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :accessor movitz-funobj-code-vector) (code-vector%1op :binary-type code-pointer :initform 'muerte::trampoline-funcall%1op @@ -858,7 +859,7 @@ :initform :default :initarg :entry-protocol :reader funobj-entry-protocol)) - (:slot-align type -2)) + (:slot-align type #.+other-type-offset+)) (defmethod write-binary-record ((obj movitz-funobj) stream) (declare (special *record-all-funobjs*)) @@ -908,12 +909,7 @@ (define-binary-class movitz-funobj-standard-gf (movitz-funobj) ;; This class is binary congruent with movitz-funobj. - ((code-vector - :binary-type code-vector-word - :initform 'muerte::standard-gf-dispatcher - :map-binary-write 'movitz-intern-code-vector - :map-binary-read-delayed 'movitz-word-code-vector) - (type + ((type :binary-type other-type-byte) (funobj-type :binary-type movitz-funobj-type @@ -922,6 +918,11 @@ ;; Bits 0-4: The value of the start-stack-frame-setup label. :binary-type 'lu16 :initform 0) + (code-vector + :binary-type code-vector-word + :initform 'muerte::standard-gf-dispatcher + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector) (code-vector%1op :initform 'muerte::standard-gf-dispatcher%1op :binary-type code-pointer @@ -993,18 +994,11 @@ :map-binary-read-delayed 'movitz-word) (plist :initform nil)) - (:slot-align type -2)) + (:slot-align type #.+other-type-offset+)) (defmethod movitz-funobj-const-list ((funobj movitz-funobj-standard-gf)) nil) -#+ignore -(defun make-movitz-funobj (lambda-list &key (name "")) - (check-type name (or symbol cons)) - (make-instance 'movitz-funobj - :lambda-list lambda-list - :name name)) - (defun make-standard-gf (class slots &key lambda-list (name "unnamed") (function 'muerte::unbound) num-required-arguments @@ -1020,51 +1014,27 @@ ;;; -#+ignore -(define-binary-class movitz-bignum (movitz-heap-object-other) - ((low32 - :binary-lisp-type u32 - :map-binary-write 'movitz-intern - :map-binary-read-delayed 'movitz-word - :initarg :name) - (type - :binary-lisp-type other-type-byte - :initform :bignum) +(define-binary-class movitz-struct (movitz-heap-object-other) + ((type + :binary-type other-type-byte + :initform :defstruct) (pad :binary-lisp-type 1) (length :binary-lisp-type lu16 :initarg :length - :accessor movitz-bignum-length) - (slot0 :binary-lisp-type :label) ; the slot values follows here. - (slot-values - :initform '() - :initarg :slot-values - :accessor movitz-struct-slot-values)) - (:slot-align type -2)) - -;;; - -(define-binary-class movitz-struct (movitz-heap-object-other) - ((name + :accessor movitz-struct-length) + (name :binary-type word :map-binary-write 'movitz-intern :map-binary-read-delayed 'movitz-word :reader movitz-struct-name :initarg :name) - (type - :binary-type other-type-byte - :initform :defstruct) - (pad :binary-lisp-type 1) - (length - :binary-lisp-type lu16 - :initarg :length - :accessor movitz-struct-length) (slot0 :binary-lisp-type :label) ; the slot values follows here. (slot-values :initform '() :initarg :slot-values :accessor movitz-struct-slot-values)) - (:slot-align type -2)) + (:slot-align type #.+other-type-offset+)) (defmethod update-movitz-object ((movitz-struct movitz-struct) lisp-struct) (declare (ignore lisp-struct)) @@ -1271,15 +1241,15 @@ ;;; std-instance (define-binary-class movitz-std-instance (movitz-heap-object-other) - ((dummy + ((type + :binary-type other-type-byte + :initform :std-instance) + (pad :binary-lisp-type 3) + (dummy :binary-type word :initform *movitz-nil* :map-binary-write 'movitz-intern :map-binary-read-delayed 'movitz-word) - (type - :binary-type other-type-byte - :initform :std-instance) - (pad :binary-lisp-type 3) (class :binary-type word :map-binary-write 'movitz-intern @@ -1292,7 +1262,7 @@ :map-binary-read-delayed 'movitz-word :initarg :slots :accessor movitz-std-instance-slots)) - (:slot-align type -2)) + (:slot-align type #.+other-type-offset+)) ;; (defmethod movitz-object-offset ((obj movitz-std-instance)) (- #x1e))

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by Frode Vatvedt Fjeld 21 May '04

21 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv25760 Modified Files: image.lisp Log Message: The layout of heap objects has been changed such that the type-code is now the "first" byte in the object. Date: Fri May 21 05:38:52 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.28 movitz/image.lisp:1.29 --- movitz/image.lisp:1.28 Wed May 19 10:59:52 2004 +++ movitz/image.lisp Fri May 21 05:38:52 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.28 2004/05/19 14:59:52 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.29 2004/05/21 09:38:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -569,9 +569,10 @@ (defmethod image-intern-object ((image symbolic-image) object &optional (size (sizeof object))) (assert ; sanity check on "other" storage-types. (or (not (typep object 'movitz-heap-object-other)) - (and (= -6 (slot-offset (type-of object) - (first (binary-record-slot-names (type-of object))))) - (= -2 (slot-offset (type-of object) 'type)))) + (and (= (- (tag :other)) + (slot-offset (type-of object) + (first (binary-record-slot-names (type-of object))))) + (= +other-type-offset+ (slot-offset (type-of object) 'type)))) () "The MOVITZ-HEAP-OBJECT-OTHER type ~A is malformed!" (type-of object)) (etypecase object

1 0

[movitz-cvs] CVS update: movitz/bootblock.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv20607 Modified Files: bootblock.lisp Log Message: Minor edits. Date: Thu May 20 14:25:12 2004 Author: ffjeld Index: movitz/bootblock.lisp diff -u movitz/bootblock.lisp:1.8 movitz/bootblock.lisp:1.9 --- movitz/bootblock.lisp:1.8 Fri Apr 16 15:15:20 2004 +++ movitz/bootblock.lisp Thu May 20 14:25:12 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Oct 9 20:47:19 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: bootblock.lisp,v 1.8 2004/04/16 19:15:20 ffjeld Exp $ +;;;; $Id: bootblock.lisp,v 1.9 2004/05/20 18:25:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -155,7 +155,6 @@ (:movw :bx :es) (:xorw :bx :bx) - (:int #x13) ; Call BIOS routine (:jc 'read-error) (:movzxb :al :ecx) @@ -285,7 +284,7 @@ ;; Data welcome (% format 8 "Loading Movitz ~D..~% " ,(incf *bootblock-build*)) - entering (% format 8 ")~% Enter..") + entering (% format 8 "~% Enter..") error (% format 8 "Failed!)") track-start-msg (% format 8 "(") track-end-msg (% format 8 ")")

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/serial.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv21517 Modified Files: serial.lisp Log Message: Header update. Date: Thu May 20 14:16:13 2004 Author: ffjeld Index: movitz/losp/x86-pc/serial.lisp diff -u movitz/losp/x86-pc/serial.lisp:1.1.1.1 movitz/losp/x86-pc/serial.lisp:1.2 --- movitz/losp/x86-pc/serial.lisp:1.1.1.1 Tue Jan 13 06:05:06 2004 +++ movitz/losp/x86-pc/serial.lisp Thu May 20 14:16:13 2004 @@ -1,16 +1,16 @@ ;;;;------------------------------------------------------------------ ;;;; ;;;; Copyright (C) 2001-2004, -;;;; Department of Computer Science, University of Tromsø, Norway. +;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. ;;;; ;;;; Filename: serial.lisp -;;;; Description: +;;;; Description: Serial port interfacing. ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 11 14:42:12 2002 ;;;; -;;;; $Id: serial.lisp,v 1.1.1.1 2004/01/13 11:05:06 ffjeld Exp $ +;;;; $Id: serial.lisp,v 1.2 2004/05/20 18:16:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/streams.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15328 Modified Files: streams.lisp Log Message: Also here prefer vector-push-extend over vector-push. Date: Thu May 20 14:13:55 2004 Author: ffjeld Index: movitz/losp/muerte/streams.lisp diff -u movitz/losp/muerte/streams.lisp:1.2 movitz/losp/muerte/streams.lisp:1.3 --- movitz/losp/muerte/streams.lisp:1.2 Mon Jan 19 06:23:47 2004 +++ movitz/losp/muerte/streams.lisp Thu May 20 14:13:55 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Jun 30 14:33:15 2003 ;;;; -;;;; $Id: streams.lisp,v 1.2 2004/01/19 11:23:47 ffjeld Exp $ +;;;; $Id: streams.lisp,v 1.3 2004/05/20 18:13:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -24,7 +24,7 @@ (:no-clos-fallback stream-no-clos)) (defmethod stream-write-char ((stream string) character) - (vector-push character stream) + (vector-push-extend character stream) character) (defmethod stream-write-char ((stream function) character) @@ -100,10 +100,10 @@ (string (case (funobj-name *forward-generic-function*) (stream-write-char - (vector-push (car args) stream) + (vector-push-extend (car args) stream) (car args)) (stream-fresh-line - (vector-push #\newline stream) + (vector-push-extend #\newline stream) t))) (function (apply stream (funobj-name *forward-generic-function*) args))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/simple-streams.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18368 Modified Files: simple-streams.lisp Log Message: Use vector-push-extend rather than vector-push when write-char to a string. Date: Thu May 20 13:48:34 2004 Author: ffjeld Index: movitz/losp/muerte/simple-streams.lisp diff -u movitz/losp/muerte/simple-streams.lisp:1.4 movitz/losp/muerte/simple-streams.lisp:1.5 --- movitz/losp/muerte/simple-streams.lisp:1.4 Wed Feb 18 09:39:37 2004 +++ movitz/losp/muerte/simple-streams.lisp Thu May 20 13:48:34 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Aug 29 13:39:43 2003 ;;;; -;;;; $Id: simple-streams.lisp,v 1.4 2004/02/18 14:39:37 ffjeld Exp $ +;;;; $Id: simple-streams.lisp,v 1.5 2004/05/20 17:48:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -427,7 +427,7 @@ (%check stream :output) (funcall-stm-handler-2 j-write-char character (sm melded-stream stream)))) (string - (vector-push character stream)))) + (vector-push-extend character stream)))) (defun %read-line (stream eof-error-p eof-value recursive-p) (declare (ignore recursive-p))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5246 Modified Files: sequences.lisp Log Message: Added a simple position-if-not. Date: Thu May 20 13:48:04 2004 Author: ffjeld Index: movitz/losp/muerte/sequences.lisp diff -u movitz/losp/muerte/sequences.lisp:1.7 movitz/losp/muerte/sequences.lisp:1.8 --- movitz/losp/muerte/sequences.lisp:1.7 Fri Apr 23 11:02:20 2004 +++ movitz/losp/muerte/sequences.lisp Thu May 20 13:48:04 2004 @@ -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.7 2004/04/23 15:02:20 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.8 2004/05/20 17:48:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -290,6 +290,9 @@ (let ((next-i (position-if predicate p :key key :from-end t))) (if next-i (+ i 1 next-i) i))))))))))))))) +(defun position-if-not (predicate sequence &rest key-args) + (declare (dynamic-extent key-args)) + (apply #'position-if (complement predicate) sequence key-args)) (defun nreverse (sequence) (sequence-dispatch sequence

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/format.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3082 Modified Files: format.lisp Log Message: For (format nil ...) make initial output string somewhat longer. Date: Thu May 20 13:47:24 2004 Author: ffjeld Index: movitz/losp/muerte/format.lisp diff -u movitz/losp/muerte/format.lisp:1.4 movitz/losp/muerte/format.lisp:1.5 --- movitz/losp/muerte/format.lisp:1.4 Tue Apr 13 10:21:57 2004 +++ movitz/losp/muerte/format.lisp Thu May 20 13:47:24 2004 @@ -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.4 2004/04/13 14:21:57 ffjeld Exp $ +;;;; $Id: format.lisp,v 1.5 2004/05/20 17:47:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -30,7 +30,7 @@ (declare (dynamic-extent args)) (let ((destination (case destination - ((nil) (make-array (* 2 (length control)) + ((nil) (make-array (* 3 (length control)) :element-type 'character :fill-pointer 0)) ((t) *standard-output*)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv31939 Modified Files: basic-macros.lisp Log Message: Make defpackage :use list translate the common-lisp package to the muerte.common-lisp package, so as to better support movitz-compiling the same code as normal. Date: Thu May 20 13:43:47 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.17 movitz/losp/muerte/basic-macros.lisp:1.18 --- movitz/losp/muerte/basic-macros.lisp:1.17 Mon Apr 19 11:06:26 2004 +++ movitz/losp/muerte/basic-macros.lisp Thu May 20 13:43:46 2004 @@ -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.17 2004/04/19 15:06:26 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.18 2004/05/20 17:43:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -65,12 +65,19 @@ (defmacro defpackage (package-name &rest options) (pushnew '(:use) options :key #'car) (let ((uses (cdr (assoc :use options)))) + (setf uses (mapcar (lambda (use) + (if (member use '(:cl :common-lisp) :test #'string=) + :muerte.cl + use)) + uses)) (when (or (null uses) (member :muerte.cl uses :test #'string=) (member :muerte.common-lisp uses :test #'string=)) - (push '(:shadowing-import-from :common-lisp nil) options))) - `(eval-when (:compile-toplevel) - (defpackage ,package-name ,@options))) + (push '(:shadowing-import-from :common-lisp nil) options)) + (let ((movitz-options (cons (cons :use uses) + (remove :use options :key #'car)))) + `(eval-when (:compile-toplevel) + (defpackage ,package-name ,@movitz-options))))) (defmacro cond (&rest clauses) (if (null clauses)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23259 Modified Files: arrays.lisp Log Message: A slightly improved vector-push-extend. Date: Thu May 20 13:41:46 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.18 movitz/losp/muerte/arrays.lisp:1.19 --- movitz/losp/muerte/arrays.lisp:1.18 Fri Apr 23 10:59:55 2004 +++ movitz/losp/muerte/arrays.lisp Thu May 20 13:41:46 2004 @@ -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.18 2004/04/23 14:59:55 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.19 2004/05/20 17:41:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -611,7 +611,16 @@ (defun vector-push-extend (new-element vector &optional extension) (declare (ignore extension)) - (vector-push new-element vector)) + (check-type vector vector) + (let ((p (vector-fill-pointer vector))) + (declare (type (unsigned-byte 16) p)) + (cond + ((< p (vector-dimension vector)) + (setf (aref vector p) new-element + (fill-pointer vector) (1+ p))) + (t (error "Vector-push extending not implemented yet."))) + p)) + (define-compiler-macro bvref-u16 (&whole form vector offset index &environment env) (let ((actual-index (and (movitz:movitz-constantp index env)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 19 May '04

19 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1920 Modified Files: integers.lisp Log Message: Added floor. Date: Wed May 19 11:42:08 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.9 movitz/losp/muerte/integers.lisp:1.10 --- movitz/losp/muerte/integers.lisp:1.9 Wed May 19 11:09:05 2004 +++ movitz/losp/muerte/integers.lisp Wed May 19 11:42:08 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.9 2004/05/19 15:09:05 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.10 2004/05/19 15:42:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1132,3 +1132,19 @@ (gcd gcd (car rest))) (rest (cdr numbers) (cdr rest))) ((null rest) gcd))))) + +(defun floor (n &optional (divisor 1)) + "This is floor written in terms of truncate." + (numargs-case + (1 (n) n) + (2 (n divisor) + (multiple-value-bind (q r) + (truncate n divisor) + (cond + ((<= 0 q) + (values q r)) + ((= 0 r) + (values q 0)) + (t (values (1- q) (+ r divisor)))))) + (t (n &optional (divisor 1)) + (floor n divisor)))) \ No newline at end of file

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 19 May '04

19 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24256 Modified Files: integers.lisp Log Message: Added gcd, mainly borrowed from cmucl. Date: Wed May 19 11:09:07 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.8 movitz/losp/muerte/integers.lisp:1.9 --- movitz/losp/muerte/integers.lisp:1.8 Fri Apr 23 09:02:22 2004 +++ movitz/losp/muerte/integers.lisp Wed May 19 11:09:05 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.8 2004/04/23 13:02:22 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.9 2004/05/19 15:09:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1103,3 +1103,32 @@ (defun minus-if (x y) (if (integerp x) (- x y) x)) +(defun gcd (&rest numbers) + (numargs-case + (1 (u) u) + (2 (u v) + ;; Code borrowed from CMUCL. + (do ((k 0 (1+ k)) + (u (abs u) (ash u -1)) + (v (abs v) (ash v -1))) + ((oddp (logior u v)) + (do ((temp (if (oddp u) (- v) (ash u -1)) + (ash temp -1))) + (nil) + (declare (fixnum temp)) + (when (oddp temp) + (if (plusp temp) + (setq u temp) + (setq v (- temp))) + (setq temp (- u v)) + (when (zerop temp) + (let ((res (ash u k))) + (declare (type (signed-byte 31) res) + (optimize (inhibit-warnings 3))) + (return res)))))))) + (t (&rest numbers) + (declare (dynamic-extent numbers)) + (do ((gcd (car numbers) + (gcd gcd (car rest))) + (rest (cdr numbers) (cdr rest))) + ((null rest) gcd)))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette-compiler.lisp
by Frode Vatvedt Fjeld 19 May '04

19 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4421 Modified Files: los-closette-compiler.lisp Log Message: Accept (but ignore) the :documentation class option. Date: Wed May 19 11:02:50 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette-compiler.lisp diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.12 movitz/losp/muerte/los-closette-compiler.lisp:1.13 --- movitz/losp/muerte/los-closette-compiler.lisp:1.12 Mon Apr 19 18:38:22 2004 +++ movitz/losp/muerte/los-closette-compiler.lisp Wed May 19 11:02:50 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.12 2004/04/19 22:38:22 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.13 2004/05/19 15:02:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -674,8 +674,9 @@ (apply #'initialize-class-object class all-keys))) (defun make-instance-standard-class (metaclass &key name direct-superclasses direct-slots - default-initargs-function) - (declare (ignore metaclass)) + default-initargs-function + documentation) + (declare (ignore metaclass documentation)) (let ((class (std-allocate-instance *the-class-standard-class*))) (setf (movitz-class-name class) name) (setf (class-direct-subclasses class) ())

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by Frode Vatvedt Fjeld 19 May '04

19 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11878 Modified Files: image.lisp Log Message: Added a small check for the package-name when dumping packages, so as not to blindly dump packages that are native to the host system should a symbol in such a package accidentally be referenced. Date: Wed May 19 10:59:53 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.27 movitz/image.lisp:1.28 --- movitz/image.lisp:1.27 Wed Apr 21 11:06:50 2004 +++ movitz/image.lisp Wed May 19 10:59:52 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.27 2004/04/21 15:06:50 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.28 2004/05/19 14:59:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1065,6 +1065,12 @@ name symbol) name))) (ensure-package (package-name lisp-package) + (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) (setf (gethash lisp-package lisp-to-movitz-package) (or (gethash package-name packages-hash nil) (let ((p (funcall 'muerte::make-package-object

1 0

[movitz-cvs] CVS update: movitz/movitz-mode.el
by Frode Vatvedt Fjeld 19 May '04

19 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv27298 Modified Files: movitz-mode.el Log Message: File-header edits. Date: Wed May 19 10:57:46 2004 Author: ffjeld Index: movitz/movitz-mode.el diff -u movitz/movitz-mode.el:1.4 movitz/movitz-mode.el:1.5 --- movitz/movitz-mode.el:1.4 Wed May 19 10:56:46 2004 +++ movitz/movitz-mode.el Wed May 19 10:57:46 2004 @@ -1,16 +1,16 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001, -;;;; Department of Computer Science, University of Tromsø, Norway. +;;;; Copyright (C) 2001, 2004 +;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. ;;;; ;;;; Filename: movitz-mode.el -;;;; Description: +;;;; Description: Modifies Franz' ELI slightly to integrate with Movitz. ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Sep 27 18:12:17 2001 ;;;; -;;;; $Id: movitz-mode.el,v 1.4 2004/05/19 14:56:46 ffjeld Exp $ +;;;; $Id: movitz-mode.el,v 1.5 2004/05/19 14:57:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

1 0

[movitz-cvs] CVS update: movitz/movitz-mode.el
by Frode Vatvedt Fjeld 19 May '04

19 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24617 Modified Files: movitz-mode.el Log Message: Don't check for movitz-package in movitz-compile-file. Date: Wed May 19 10:56:46 2004 Author: ffjeld Index: movitz/movitz-mode.el diff -u movitz/movitz-mode.el:1.3 movitz/movitz-mode.el:1.4 --- movitz/movitz-mode.el:1.3 Mon Feb 2 08:31:23 2004 +++ movitz/movitz-mode.el Wed May 19 10:56:46 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Sep 27 18:12:17 2001 ;;;; -;;;; $Id: movitz-mode.el,v 1.3 2004/02/02 13:31:23 ffjeld Exp $ +;;;; $Id: movitz-mode.el,v 1.4 2004/05/19 14:56:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -113,12 +113,11 @@ (defun movitz-compile-file () (interactive) - (when (in-movitz-package-p) - (save-some-buffers) - (message "Movitz compiling \"%s\"..." (buffer-file-name)) - (fi:eval-in-lisp "(movitz:movitz-compile-file \"%s\")" (buffer-file-name)) - (message "Movitz compiling \"%s\"...done." - (buffer-file-name)))) + (save-some-buffers) + (message "Movitz compiling \"%s\"..." (buffer-file-name)) + (fi:eval-in-lisp "(movitz:movitz-compile-file \"%s\")" (buffer-file-name)) + (message "Movitz compiling \"%s\"...done." + (buffer-file-name))) (defun movitz-eval-in-acl (string msg) (fi::note-background-request nil) @@ -284,6 +283,11 @@ (when (in-movitz-package-p) (message "Switching to Movitz keymap.") (use-local-map (make-movitz-common-lisp-mode-map))))) + +(defun movitz-mode () + "Switch on Movitz-mode." + (interactive) + (use-local-map (make-movitz-common-lisp-mode-map))) (let ((tag 'fi:common-lisp-indent-hook)) (put 'compiler-values tag '(like with-open-file))

1 0

[movitz-cvs] CVS update: movitz/losp/tmp/harddisk.lisp
by Frode Vatvedt Fjeld 11 May '04

11 May '04

Update of /project/movitz/cvsroot/movitz/losp/tmp In directory common-lisp.net:/tmp/cvs-serv3598 Modified Files: harddisk.lisp Log Message: Updates from Peter Minten. Date: Tue May 11 11:05:28 2004 Author: ffjeld Index: movitz/losp/tmp/harddisk.lisp diff -u movitz/losp/tmp/harddisk.lisp:1.3 movitz/losp/tmp/harddisk.lisp:1.4 --- movitz/losp/tmp/harddisk.lisp:1.3 Wed May 5 04:26:14 2004 +++ movitz/losp/tmp/harddisk.lisp Tue May 11 11:05:25 2004 @@ -1,4 +1,4 @@ -;;;; $Id: harddisk.lisp,v 1.3 2004/05/05 08:26:14 ffjeld Exp $ +;;;; $Id: harddisk.lisp,v 1.4 2004/05/11 15:05:25 ffjeld Exp $ (require :lib/named-integers) @@ -7,6 +7,7 @@ (defpackage muerte.x86-pc.harddisk (:use muerte.cl muerte muerte.lib muerte.x86-pc) (:export hdc-reset + hd-identify-device hd-read-sectors hd-write-sectors)) @@ -118,19 +119,35 @@ (setf (lba-low-register hdc) (ldb (byte 8 0) lba)) (setf (lba-mid-register hdc) (ldb (byte 8 8) lba)) (setf (lba-high-register hdc) (ldb (byte 8 16) lba)) - (setf (device-register hdc) (dpb (ash (ldb (byte 4 24) lba) -24) + (setf (device-register hdc) (dpb (ldb (byte 4 24) lba) (byte 4 0) (device-register hdc)))) +(defun set-lba-address-ext (hdc lba) + (setf (lba-low-register hdc) (ldb (byte 8 0) lba)) + (setf (lba-mid-register hdc) (ldb (byte 8 8) lba)) + (setf (lba-high-register hdc) (ldb (byte 8 16) lba)) + + ;; movitz byte function has a restriction, the location must be <= 30 + ;; therefore this workaround + (setf (lba-low-register hdc) (ldb (byte 8 0) (ash lba -24))) + (setf (lba-mid-register hdc) (ldb (byte 8 8) (ash lba -24))) + (setf (lba-high-register hdc) (ldb (byte 8 16) (ash lba -24)))) + (defun set-sector-count (hdc count) (setf (sector-count-register hdc) count)) +(defun set-sector-count-ext (hdc count) + (setf (sector-count-register hdc) (ldb (byte 8 0) count)) + (setf (sector-count-register hdc) (ldb (byte 8 8) count))) + (defun set-command (hdc command) - (let ((command-code (case command - ('read-sectors-with-retry #x20) - ('write-sectors-with-retry #x30) - ('identify-drive #xCE)))) - (setf (command-register hdc) command-code))) + (setf (command-register hdc) (case command + ('identify-drive #xEC) + ('read-sectors #x20) + ('read-sectors-ext #x24) + ('write-sectors #x30) + ('write-sectors-ext #x34)))) ;;; ;;; misc @@ -139,11 +156,7 @@ (/= 0 (ldb (byte 1 number) place))) (defmacro set-bit (number value place) - (let ((gs-number (gensym "number-"))) - `(if ,value - (let ((,gs-number ,number)) - (setf ,place (dpb (ash 1 ,gs-number) (byte 1 ,gs-number) ,place))) - (setf ,place (dpb 0 (byte 1 ,number) ,place))))) + `(setf ,place (dpb (if ,value 1 0) (byte 1 ,number) ,place))) (defmacro while (test &body body) `(do () ((not ,test)) @@ -206,9 +219,57 @@ (loop for x from 1 to 2500) (loop while (reg-bsy hdc)))) +(defun hd-identify-device (hdnr) + "Get device information of hdnr. Returns a (vector 256 (unsigned-byte 16))." + (let ((data (make-array 256 :element-type :unsigned-byte16)) + (offset 0)) + (with-hd-info (hdc drive) hdnr + (tagbody + ;; drive must be ready + ;; drive number must be set + ;; intrq's must not be used + ;; LBA mode must be on + ;; LBA must be set + ;; sector-count must be set + ;; command must be entered + ;; 400 nsec must be waited before checking BSY + (loop until (reg-drdy hdc)) + (loop while (reg-alt-bsy hdc)) + (set-drive-number hdc drive) + (set-intrq-mode hdc nil) + (set-command hdc 'identify-drive) + (dotimes (x 500)) ;aught to be enough waiting + (go :check-status) + ;;;;;;;;;;;;;;;;;; + :check-status + ;; if BSY=0 and DRQ=0 then error + ;; if BSY=0 and DRQ=1 then go transfer-data + ;; if BSY=1 then go check-state + (let ((status (status-register hdc))) + (if (get-bit 7 status) ;if BSY = 1 + (go :check-status) + (if (get-bit 3 status) ;if DRQ = 1 + (go :transfer-data) + (progn + (hdc-error hdc "identify-device" hdnr))))) + ;;;;;;;;;;;;;;;;;; + :transfer-data + ;; read the data register + (setf (aref data offset) (data-register hdc)) + (incf offset) + ;; read the status register to determine if we're done + (if (reg-drq hdc) + (if (< offset 256) + (go :transfer-data) ;data block not completely transfered + (go :check-status)) + (return-from hd-identify-device data)))))) + (defun hd-read-sectors (hdnr start-sector count) + "Read count sectors from hdnr, starting at start-sector. Returns a (vector (* count 512) (unsigned-byte 8)). If start-sector doesn't fit into 28 bits or count doesn't fit into 8 bits an attempt is made to use 48 bits addressing." (let ((data (make-array (* count 512) :element-type :unsigned-byte8)) (offset 0) + (ext-mode (or (>= start-sector #xFFFFFFF) + (>= count #xFF))) input) (with-hd-info (hdc drive) hdnr (tagbody @@ -226,9 +287,20 @@ (set-drive-number hdc drive) (set-intrq-mode hdc nil) (set-lba-mode hdc t) + (if ext-mode + (progn + (puts "using 48 bits addressing") + (set-lba-address-ext hdc start-sector) + (set-sector-count-ext hdc count) + (set-command hdc 'read-sectors-ext)) + (progn + (puts "using 28 bits addressing") + (set-lba-address hdc start-sector) + (set-sector-count hdc count) + (set-command hdc 'read-sectors))) (set-lba-address hdc start-sector) (set-sector-count hdc count) - (set-command hdc 'read-sectors-with-retry) + (set-command hdc 'read-sectors) (dotimes (x 500)) ;aught to be enough waiting (go :check-status) ;;;;;;;;;;;;;;;;;; @@ -266,8 +338,10 @@ (check-type hdnr (integer 0 *)) (check-type start-sector (integer 0 *)) (check-type data vector) - (let ((count (truncate (length data) 512)) - (offset 0)) + (let* ((count (truncate (length data) 512)) + (ext-mode (or (>= start-sector #xFFFFFFF) + (>= count #xFF))) + (offset 0)) (with-hd-info (hdc drive) hdnr (tagbody ; (puts "in entry") @@ -284,9 +358,20 @@ (set-drive-number hdc drive) (set-intrq-mode hdc nil) (set-lba-mode hdc t) + (if ext-mode + (progn + (puts "using 48 bits addressing") + (set-lba-address-ext hdc start-sector) + (set-sector-count-ext hdc count) + (set-command hdc 'write-sectors-ext)) + (progn + (puts "using 28 bits addressing") + (set-lba-address hdc start-sector) + (set-sector-count hdc count) + (set-command hdc 'write-sectors))) (set-lba-address hdc start-sector) (set-sector-count hdc count) - (set-command hdc 'write-sectors-with-retry) + (set-command hdc 'write-sectors) (dotimes (x 500)) ;aught to be enough waiting (go :check-status) ;;;;;;;;;;;;;;;;;; @@ -315,4 +400,4 @@ (progn (alt-status-register hdc) ;read and ignore (go :check-status))) - (return-from hd-write-sectors nil)))))) + (return-from hd-write-sectors nil)))))) \ No newline at end of file

1 0

[movitz-cvs] CVS update: movitz/losp/tmp/harddisk.lisp
by Frode Vatvedt Fjeld 05 May '04

05 May '04

Update of /project/movitz/cvsroot/movitz/losp/tmp In directory common-lisp.net:/tmp/cvs-serv10011 Modified Files: harddisk.lisp Log Message: Checked in new version from Peter Minten. Date: Wed May 5 04:26:14 2004 Author: ffjeld Index: movitz/losp/tmp/harddisk.lisp diff -u movitz/losp/tmp/harddisk.lisp:1.2 movitz/losp/tmp/harddisk.lisp:1.3 --- movitz/losp/tmp/harddisk.lisp:1.2 Sat Apr 24 11:13:26 2004 +++ movitz/losp/tmp/harddisk.lisp Wed May 5 04:26:14 2004 @@ -1,264 +1,318 @@ -;;;; $Id: harddisk.lisp,v 1.2 2004/04/24 15:13:26 ffjeld Exp $ - -(require :lib/named-integers) -(provide :tmp/harddisk) - -(defpackage muerte.x86-pc.harddisk - (:use muerte.cl muerte muerte.lib muerte.x86-pc) - (:export make-512-vector - hd-read-sectors - hd-write-sectors - hd-commands - )) - -(in-package muerte.x86-pc.harddisk) - -;;; -;;; global variables -;;; -(defvar *hd-controllers* (vector (make-instance 'hd-controller)) - "A vector of harddisk controllers.") - -;;; -;;; constants -;;; -(defconstant +hd-default-first-irq+ 14) -(defconstant +hd-default-second-irq+ 15) -(defconstant +hd-default-first-command-base+ #x1F0) -(defconstant +hd-default-second-command-base+ #x170) -(defconstant +hd-default-first-control-base+ #x3F6) -(defconstant +hd-default-second-control-base+ #x376) - -(define-named-integer hd-register-offset - (:only-constants t) - (0 data) - (1 error) - (1 features) - (2 sector-count) - (3 lba-byte-1) ;bits 0-7 - (4 lba-byte-2) ;bits 8-15 - (5 lba-byte-3) ;bits 16-23 - (6 lba-byte-4) ;bits 24-27 - (7 status) - (7 command)) - -(define-named-integer hd-commands - (:only-constants t) - (#x20 read-sectors-with-retry) - (#x30 write-sectors-with-retry)) - -(define-named-integer hd-status-bits - (:only-constants t) - (0 error) - (1 index) - (2 corrected-data) - (3 data-request) - (4 drive-seek-complete) - (5 drive-write-fault) - (6 drive-ready) - (7 busy)) - -;;; -;;; classes -;;; -(defclass hd-controller () - ((command-base :initform +hd-default-first-command-base+ - :initarg :command-base - :type integer) - (control-base :initform +hd-default-first-control-base+ - :initarg :command-base - :type integer))) - -;;; -;;; waiters -;;; -(defun hd-controller-wait-for-drive-ready (hdc) ;wait for DRDY=1 - (with-slots (control-base) hdc - (loop until (/= 0 (logand (io-port control-base :unsigned-byte8) - #x40))))) - -(defun hd-controller-wait-for-ready (hdc) ;wait for BSY=0 - (with-slots (control-base) hdc - (loop until (= 0 (logand (io-port control-base :unsigned-byte8) - #x80))))) - -(defun hd-controller-wait-for-data-request (hdc) ;wait for DRQ=1 - (with-slots (control-base) hdc - (loop until (/= 0 (logand (io-port control-base :unsigned-byte8) - #x08))))) - -;;; -;;; feeders -;;; -(defun hd-controller-feed-lba-mode (hdc) - (setf (io-port (hd-controller-command-register hdc 'lba-byte-4) - :unsigned-byte8) - (logior (io-port (hd-controller-command-register hdc 'lba-byte-4) - :unsigned-byte8) - #b01000000))) - -(defun hd-controller-feed-drive (hdc drive) - (setf (io-port (hd-controller-command-register hdc 'lba-byte-4) - :unsigned-byte8) - (logior (* #b00010000 drive) - (logand (io-port (hd-controller-command-register hdc 'lba-byte-4) - :unsigned-byte8) - #b11101111)))) - -(defun hd-controller-feed-lba-address (hdc lba) - (setf (io-port (hd-controller-command-register hdc 'lba-byte-1) - :unsigned-byte8) - (logand lba #x000000FF)) - (setf (io-port (hd-controller-command-register hdc 'lba-byte-2) - :unsigned-byte8) - (logand lba #x0000FF00)) - (setf (io-port (hd-controller-command-register hdc 'lba-byte-3) - :unsigned-byte8) - (logand lba #x00FF0000)) - (setf (io-port (hd-controller-command-register hdc 'lba-byte-3) - :unsigned-byte8) - (logior (io-port (hd-controller-command-register hdc 'lba-byte-4) - :unsigned-byte8) - (logand lba #x000F0000)))) - -;;; -;;; misc -;;; -(defmacro while (test &body body) - `(do () ((not ,test)) - ,@body)) - -(defun div (a b) - "Floored integer division, the painful way." - (let ((r 0) - (x a)) - (while (>= x 0) - (decf x b) - (incf r)) - (1- r))) - -(defun log2 (n) - (cond ((= n 256) 8) - ((= n 128) 7) - ((= n 64) 6) - ((= n 32) 5) - ((= n 16) 4) - ((= n 8) 3) - ((= n 4) 2) - ((= n 2) 1) - ((= n 1) 0))) - -(defmacro with-hd-info ((hdc drive-number) hd-number &body body) - (let ((gs-hdnr (gensym "hd-number-"))) - `(let* ((,gs-hdnr ,hd-number) - (,hdc (aref *hd-controllers* (div ,hd-number 2))) - (,drive-number (mod ,gs-hdnr 2))) - ,@body))) - -(defun hd-controller-command-register (hdc name) - ;; use a case statement for now, until I learn how to use - ;; named-integer right - (+ (case name - ('data 0) - ('error 1) - ('features 1) - ('sector-count 2) - ('lba-byte-1 3) - ('lba-byte-2 4) - ('lba-byte-3 5) - ('lba-byte-4 6) - ('status 7) - ('command 7) - (else (error "HD command register not found ~A" name))) - (slot-value hdc 'command-base))) - -(defun error-code-meaning (code) - (nth (log2 code) - '("Address Mark Not Found" - "Track 0 Not Found" - "Media Change Requested" - "Aborted Command" - "ID Not Found" - "Media Changed" - "Uncorrectable Data Error" - "Bad Block Detected"))) - - -(defun hd-check-error (hdc command-name hdnr) - "Check and when found signal an error in task." - (when (/= 0 (logand (io-port (slot-value hdc 'control-base) - :unsigned-byte8) - #x01)) - (error "Harddrive command ~A returned error. HD number: ~A. Error message: '~A'." - command-name hdnr - (error-code-meaning - (io-port (hd-controller-command-register hdc 'error) - :unsigned-byte8))))) - -;;; -;;; hd operations -;;; -(defun hd-read-sectors (hdnr start-sector count) - (let ((data (make-array 512 :element-type :unsigned-byte8)) - (offset 0) - (read-data nil)) - (with-hd-info (hdc drive) hdnr - ;; set drive - (hd-controller-feed-drive hdc drive) - ;; set count - (setf (io-port (hd-controller-command-register hdc 'sector-count) - :unsigned-byte8) - count) - ;; set LBA and address - (hd-controller-feed-lba-mode hdc) - (hd-controller-feed-lba-address hdc start-sector) - ;; get going - (setf (io-port (hd-controller-command-register hdc 'command) - :unsigned-byte8) - +hd-commands-read-sectors-with-retry+) - ;; data handling - (while (<= offset (* count 512)) - (hd-controller-wait-for-drive-ready hdc) - (hd-controller-wait-for-ready hdc) - (hd-check-error hdc "read-sectors" hdnr) - (hd-controller-wait-for-data-request hdc) - (dotimes (i 256) - (setf read-data (io-port (hd-controller-command-register hdc 'status) - :unsigned-byte16))) - (setf (aref data offset) (logand read-data #xFF)) - (setf (aref data (1+ offset)) (logand read-data #xFF00)) - (incf offset 2)) - ;; done - data))) - -(defun hd-write-sectors (hdnr start-sector data) - (let ((offset 0) - (write-data nil) - (count (div (length data) 512))) - (with-hd-info (hdc drive) hdnr - ;; set drive - (hd-controller-feed-drive hdc drive) - ;; set count - (setf (io-port (hd-controller-command-register hdc 'sector-count) - :unsigned-byte8) - count) - ;; set LBA and address - (hd-controller-feed-lba-mode hdc) - (hd-controller-feed-lba-address hdc start-sector) - ;; get going - (setf (io-port (hd-controller-command-register hdc 'command) - :unsigned-byte8) - +hd-commands-write-sectors-with-retry+) - ;; data handling - (while (<= offset (* count 512)) - (hd-controller-wait-for-drive-ready hdc) - (hd-controller-wait-for-ready hdc) - (hd-check-error hdc "write-sectors" hdnr) - (hd-controller-wait-for-data-request hdc) - (dotimes (i 256) - (setf write-data (aref data offset)) - (incf write-data (* #xFF (aref data (1+ offset)))) - (setf (io-port (hd-controller-command-register hdc 'data) - :unsigned-byte16) - write-data) - (incf offset 2)))))) \ No newline at end of file +;;;; $Id: harddisk.lisp,v 1.3 2004/05/05 08:26:14 ffjeld Exp $ + +(require :lib/named-integers) + +(provide :tmp/harddisk) + +(defpackage muerte.x86-pc.harddisk + (:use muerte.cl muerte muerte.lib muerte.x86-pc) + (:export hdc-reset + hd-read-sectors + hd-write-sectors)) + +(in-package muerte.x86-pc.harddisk) + +;;; +;;; global variables +;;; +(defvar *hd-controllers* (vector (make-instance 'hd-controller)) + "A vector of harddisk controllers.") + +;;; +;;; constants +;;; +(defconstant +hd-default-first-irq+ 14) +(defconstant +hd-default-second-irq+ 15) +(defconstant +hd-default-first-command-base+ #x1F0) +(defconstant +hd-default-second-command-base+ #x170) +(defconstant +hd-default-first-control-base+ #x3F6) +(defconstant +hd-default-second-control-base+ #x376) + +;;; +;;; classes +;;; +(defclass hd-controller () + ((command-base :initform +hd-default-first-command-base+ + :initarg :command-base + :type integer) + (control-base :initform +hd-default-first-control-base+ + :initarg :command-base + :type integer))) +;;; +;;; accessors +;;; + +(defmacro data-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 0) :unsigned-byte16)) + +(defmacro features-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 1) :unsigned-byte8)) + +(defmacro error-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 1) :unsigned-byte8)) + +(defmacro sector-count-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 2) :unsigned-byte8)) + +(defmacro lba-low-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 3) :unsigned-byte8)) + +(defmacro lba-mid-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 4) :unsigned-byte8)) + +(defmacro lba-high-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 5) :unsigned-byte8)) + +(defmacro device-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 6) :unsigned-byte8)) + +(defmacro command-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 7) :unsigned-byte8)) + +(defmacro status-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 7) :unsigned-byte8)) + +(defmacro alt-status-register (hdc) + `(io-port (slot-value ,hdc 'control-base) :unsigned-byte8)) + +;;; +;;; getters +;;; +(defun reg-bsy (hdc) + (get-bit 7 (status-register hdc))) + +(defun reg-drdy (hdc) + (get-bit 6 (status-register hdc))) + +(defun reg-drq (hdc) + (get-bit 3 (status-register hdc))) + +(defun reg-err (hdc) + (get-bit 0 (status-register hdc))) + +(defun reg-alt-bsy (hdc) + (get-bit 7 (alt-status-register hdc))) + +(defun reg-alt-drdy (hdc) + (get-bit 6 (alt-status-register hdc))) + +(defun reg-alt-drq (hdc) + (get-bit 3 (alt-status-register hdc))) + +(defun reg-alt-err (hdc) + (get-bit 3 (alt-status-register hdc))) + +;;; +;;; setters +;;; +(defun set-drive-number (hdc drive) + (set-bit 4 (/= drive 0) (device-register hdc))) + +(defun set-intrq-mode (hdc mode) + (set-bit 1 (not mode) (device-register hdc))) + +(defun set-lba-mode (hdc mode) + (set-bit 6 mode (device-register hdc))) + +(defun set-lba-address (hdc lba) + (setf (lba-low-register hdc) (ldb (byte 8 0) lba)) + (setf (lba-mid-register hdc) (ldb (byte 8 8) lba)) + (setf (lba-high-register hdc) (ldb (byte 8 16) lba)) + (setf (device-register hdc) (dpb (ash (ldb (byte 4 24) lba) -24) + (byte 4 0) + (device-register hdc)))) + +(defun set-sector-count (hdc count) + (setf (sector-count-register hdc) count)) + +(defun set-command (hdc command) + (let ((command-code (case command + ('read-sectors-with-retry #x20) + ('write-sectors-with-retry #x30) + ('identify-drive #xCE)))) + (setf (command-register hdc) command-code))) + +;;; +;;; misc +;;; +(defun get-bit (number place) + (/= 0 (ldb (byte 1 number) place))) + +(defmacro set-bit (number value place) + (let ((gs-number (gensym "number-"))) + `(if ,value + (let ((,gs-number ,number)) + (setf ,place (dpb (ash 1 ,gs-number) (byte 1 ,gs-number) ,place))) + (setf ,place (dpb 0 (byte 1 ,number) ,place))))) + +(defmacro while (test &body body) + `(do () ((not ,test)) + ,@body)) + +(defun log2 (n) + (cond ((= n 256) 8) + ((= n 128) 7) + ((= n 64) 6) + ((= n 32) 5) + ((= n 16) 4) + ((= n 8) 3) + ((= n 4) 2) + ((= n 2) 1) + ((= n 1) 0))) + +(defmacro with-hd-info ((hdc drive-number) hd-number &body body) + (let ((gs-hdnr (gensym "hd-number-"))) + `(let* ((,gs-hdnr ,hd-number) + (,hdc (aref *hd-controllers* (truncate ,hd-number 2))) + (,drive-number (mod ,gs-hdnr 2))) + ,@body))) + +(defun error-code-meaning (code) + (if (< 0 code 257) + (nth (log2 code) + '("Address Mark Not Found" + "Track 0 Not Found" + "Media Change Requested" + "Aborted Command" + "ID Not Found" + "Media Changed" + "Uncorrectable Data Error" + "Bad Block Detected")) + "No error")) + +(defun hdc-error (hdc command-name hdnr) + (puts "In HDC error") + (error "Harddrive command ~A returned error. HD number: ~A. Error message: '~A'." + command-name hdnr + (error-code-meaning + (io-port (error-register hdc) :unsigned-byte8)))) + +(defun puts (s) + (fresh-line) + (format t s) + (terpri)) + +;;; +;;; hd operations +;;; +(defun hdc-reset (hdcnr) + "Reset the harddisk controller. Must be done at startup to +initialize the harddisk controller." + ;; set SRST + ;; wait > 2ms + ;; continue when BSY=0 + (let ((hdc (aref *hd-controllers* hdcnr))) + (setf (device-register hdc) #x04) + (loop for x from 1 to 2500) + (loop while (reg-bsy hdc)))) + +(defun hd-read-sectors (hdnr start-sector count) + (let ((data (make-array (* count 512) :element-type :unsigned-byte8)) + (offset 0) + input) + (with-hd-info (hdc drive) hdnr + (tagbody +; (puts "in entry") + ;; drive must be ready + ;; drive number must be set + ;; intrq's must not be used + ;; LBA mode must be on + ;; LBA must be set + ;; sector-count must be set + ;; command must be entered + ;; 400 nsec must be waited before checking BSY + (loop until (reg-drdy hdc)) + (loop while (reg-alt-bsy hdc)) + (set-drive-number hdc drive) + (set-intrq-mode hdc nil) + (set-lba-mode hdc t) + (set-lba-address hdc start-sector) + (set-sector-count hdc count) + (set-command hdc 'read-sectors-with-retry) + (dotimes (x 500)) ;aught to be enough waiting + (go :check-status) + ;;;;;;;;;;;;;;;;;; + :check-status +; (puts "in check-status") + ;; if BSY=0 and DRQ=0 then error + ;; if BSY=0 and DRQ=1 then go transfer-data + ;; if BSY=1 then go check-state + (let ((status (status-register hdc))) + (if (get-bit 7 status) ;if BSY = 1 + (go :check-status) + (if (get-bit 3 status) ;if DRQ = 1 + (go :transfer-data) + (progn + (hdc-error hdc "read-sectors" hdnr))))) + ;;;;;;;;;;;;;;;;;; + :transfer-data +; (puts "in transfer-data") + ;; read the data register + (setf input (data-register hdc)) + (setf (aref data offset) (ldb (byte 8 0) input)) + (incf offset) + (setf (aref data offset) (ldb (byte 8 8) input)) + (incf offset) + ;; read the status register to determine if we're done + (if (reg-drq hdc) + (if (/= 0 (mod offset 512)) + (go :transfer-data) ;data block not completely transfered + (progn + (alt-status-register hdc) ;read and ignore + (go :check-status))) + (return-from hd-read-sectors data)))))) + +(defun hd-write-sectors (hdnr start-sector data) + (check-type hdnr (integer 0 *)) + (check-type start-sector (integer 0 *)) + (check-type data vector) + (let ((count (truncate (length data) 512)) + (offset 0)) + (with-hd-info (hdc drive) hdnr + (tagbody +; (puts "in entry") + ;; drive must be ready + ;; drive number must be set + ;; intrq's must not be used + ;; LBA mode must be on + ;; LBA must be set + ;; sector-count must be set + ;; command must be entered + ;; 400 nsec must be waited before checking BSY + (loop until (reg-drdy hdc)) + (loop while (reg-alt-bsy hdc)) + (set-drive-number hdc drive) + (set-intrq-mode hdc nil) + (set-lba-mode hdc t) + (set-lba-address hdc start-sector) + (set-sector-count hdc count) + (set-command hdc 'write-sectors-with-retry) + (dotimes (x 500)) ;aught to be enough waiting + (go :check-status) + ;;;;;;;;;;;;;;;;;; + :check-status +; (puts "in check-status") + ;; if BSY=0 and DRQ=0 then error + ;; if BSY=0 and DRQ=1 then go transfer-data + ;; if BSY=1 then go + (let ((status (status-register hdc))) + (if (get-bit 7 status) ;if BSY = 1 + (go :check-status) + (if (get-bit 3 status) ;if DRQ = 1 + (go :transfer-data) + (hdc-error hdc "write-sectors" hdnr)))) + ;;;;;;;;;;;;;;;;;; + :transfer-data +; (puts "in transfer-data") + ;; read the data register + (setf (data-register hdc) (+ (aref data offset) + (ash (aref data (1+ offset)) 8))) + (incf offset 2) + ;; read the status register to determine if we're done + (if (reg-drq hdc) + (if (/= 0 (mod offset 512)) + (go :transfer-data) ;data block not completely transfered + (progn + (alt-status-register hdc) ;read and ignore + (go :check-status))) + (return-from hd-write-sectors nil))))))

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/pci.lisp
by Frode Vatvedt Fjeld 05 May '04

05 May '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv3649 Modified Files: pci.lisp Log Message: Changed the with-named-integers-syntax macro a bit, trying to make this mechanism a bit more general and useful. Date: Wed May 5 04:24:38 2004 Author: ffjeld Index: movitz/losp/x86-pc/pci.lisp diff -u movitz/losp/x86-pc/pci.lisp:1.2 movitz/losp/x86-pc/pci.lisp:1.3 --- movitz/losp/x86-pc/pci.lisp:1.2 Fri Apr 23 11:04:17 2004 +++ movitz/losp/x86-pc/pci.lisp Wed May 5 04:24:38 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.2 2004/04/23 15:04:17 ffjeld Exp $ +;;;; $Id: pci.lisp,v 1.3 2004/05/05 08:24:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -18,7 +18,7 @@ (provide :x86-pc/pci) -(defun bios32-find () +(defun find-bios32 () (loop for bios32 from #xe0000 to #xffff0 by 16 if (and (= (memref-int bios32 0 0 :unsigned-byte16 t) #x335f) (= (memref-int bios32 0 1 :unsigned-byte16 t) #x5f32)

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/dp8390.lisp
by Frode Vatvedt Fjeld 05 May '04

05 May '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv2985 Modified Files: dp8390.lisp Log Message: Changed the with-named-integers-syntax macro a bit, trying to make this mechanism a bit more general and useful. Date: Wed May 5 04:24:31 2004 Author: ffjeld Index: movitz/losp/x86-pc/dp8390.lisp diff -u movitz/losp/x86-pc/dp8390.lisp:1.6 movitz/losp/x86-pc/dp8390.lisp:1.7 --- movitz/losp/x86-pc/dp8390.lisp:1.6 Thu Feb 26 06:19:17 2004 +++ movitz/losp/x86-pc/dp8390.lisp Wed May 5 04:24:29 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Sep 18 12:21:36 2002 ;;;; -;;;; $Id: dp8390.lisp,v 1.6 2004/02/26 11:19:17 ffjeld Exp $ +;;;; $Id: dp8390.lisp,v 1.7 2004/05/05 08:24:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,19 +22,20 @@ (in-package muerte.x86-pc.ne2k) (defconstant +page0-read-map+ - #(cr clda0 clda1 bnry tsr ncr fifo isr crda0 crda1 rbcr0 rbcr1 rsr cntr0 cntr1 cntr2)) + '(:enum cr clda0 clda1 bnry tsr ncr fifo isr crda0 crda1 rbcr0 rbcr1 rsr cntr0 cntr1 cntr2)) (defconstant +page0-write-map+ - #(cr pstart pstop bnry tpsr tbcr0 tbcr1 isr rsar0 rsar1 rbcr0 rbcr1 rcr tcr dcr imr)) + '(:enum cr pstart pstop bnry tpsr tbcr0 tbcr1 isr rsar0 rsar1 rbcr0 rbcr1 rcr tcr dcr imr)) (defconstant +page1-read-map+ - #(nil nil nil nil nil nil nil curr)) + '(:enum nil nil nil nil nil nil nil curr)) (defconstant +page1-write-map+ - #(cr par0 par1 par2 par3 par4 par5 curr mar0 mar1 mar2 mar3 mar4 mar5 mar6 mar7)) + '(:enum cr par0 par1 par2 par3 par4 par5 curr mar0 mar1 mar2 mar3 mar4 mar5 mar6 mar7)) (defconstant +command-map+ - '((#b001 . stop) + '(:rassoc + (#b001 . stop) (#b010 . start) (#b100 . transmit) (#o10 . remote-read) @@ -47,7 +48,8 @@ (#xc0 . page-3))) (defconstant +interrupt-status-map+ - #(packet-received + '(:enum + packet-received packet-transmitted receive-error transmit-error @@ -57,7 +59,8 @@ reset-status)) (defconstant +data-config-map+ - '((#x01 . dma-16-bit) + '(:rassoc + (#x01 . dma-16-bit) (#x02 . big-endian) (#x04 . dma-address-32bit) (#x08 . loopback-off) @@ -68,13 +71,15 @@ (#x60 . fifo-threshold-12-bytes))) (defconstant +tx-config-map+ - '((#x00 . loopback-mode-0) + '(:rassoc + (#x00 . loopback-mode-0) (#x02 . loopback-mode-1) (#x04 . loopback-mode-2) (#x06 . loopback-mode-3))) (defconstant +rx-config-map+ - '((#x01 . save-error-packets) + '(:rassoc + (#x01 . save-error-packets) (#x02 . runt-packets) (#x04 . broadcast) (#x08 . multicast) @@ -82,7 +87,7 @@ (#x20 . monitor-mode))) (defconstant +command-bit-map+ - #(stop start transmit)) + '(:enum stop start transmit)) ;;; Convenience syntax

1 0

[movitz-cvs] CVS update: movitz/losp/lib/named-integers.lisp
by Frode Vatvedt Fjeld 05 May '04

05 May '04

Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv2468 Modified Files: named-integers.lisp Log Message: Changed the with-named-integers-syntax macro a bit, trying to make this mechanism a bit more general and useful. Date: Wed May 5 04:24:22 2004 Author: ffjeld Index: movitz/losp/lib/named-integers.lisp diff -u movitz/losp/lib/named-integers.lisp:1.3 movitz/losp/lib/named-integers.lisp:1.4 --- movitz/losp/lib/named-integers.lisp:1.3 Mon Jan 19 06:23:44 2004 +++ movitz/losp/lib/named-integers.lisp Wed May 5 04:24:21 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jan 4 16:13:46 2002 ;;;; -;;;; $Id: named-integers.lisp,v 1.3 2004/01/19 11:23:44 ffjeld Exp $ +;;;; $Id: named-integers.lisp,v 1.4 2004/05/05 08:24:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -20,13 +20,14 @@ (in-package muerte.lib) -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (:compile-toplevel :load-toplevel) (defun name->integer (map name) (if (integerp name) name - (or (etypecase map - (vector (position name map)) - (list (car (rassoc name map)))) + (or (ecase (car map) + (:enum (position name (cdr map))) + (:assoc (cdr (assoc name (cdr map)))) + (:rassoc (car (rassoc name (cdr map))))) (error "No integer named ~S in ~S." name map)))) (defun names->integer (map &rest names) (declare (dynamic-extent names)) @@ -34,11 +35,13 @@ sum (name->integer map name)))) (defmacro with-named-integers-syntax (name-maps &body body) - `(macrolet ,(mapcar (lambda (name-map) - (destructuring-bind (name map) - name-map - `(,name (&rest names) (apply 'muerte.lib:names->integer ,map names)))) - name-maps) + `(macrolet + ,(mapcar (lambda (name-map) + (destructuring-bind (name map) + name-map + `(,name (&rest names) + (apply 'muerte.lib:names->integer ,map names)))) + name-maps) ,@body)) (define-compile-time-variable *name-to-integer-tables*

1 0