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

[movitz-cvs] CVS update: movitz/losp/muerte/common-lisp.lisp
by Frode Vatvedt Fjeld 27 Jul '04

27 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16675 Modified Files: common-lisp.lisp Log Message: Let's have ratios! Date: Tue Jul 27 06:54:08 2004 Author: ffjeld Index: movitz/losp/muerte/common-lisp.lisp diff -u movitz/losp/muerte/common-lisp.lisp:1.11 movitz/losp/muerte/common-lisp.lisp:1.12 --- movitz/losp/muerte/common-lisp.lisp:1.11 Tue Jul 20 16:51:01 2004 +++ movitz/losp/muerte/common-lisp.lisp Tue Jul 27 06:54:07 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:41:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: common-lisp.lisp,v 1.11 2004/07/20 23:51:01 ffjeld Exp $ +;;;; $Id: common-lisp.lisp,v 1.12 2004/07/27 13:54:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -37,6 +37,7 @@ (require :muerte/los-closette) (require :muerte/defstruct) (require :muerte/hash-tables) +(require :muerte/ratios) (require :muerte/packages) (require :muerte/format) (require :muerte/error)

1 0

[movitz-cvs] CVS update: movitz/losp/los0-gc.lisp
by Frode Vatvedt Fjeld 27 Jul '04

27 Jul '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv10842 Modified Files: los0-gc.lisp Log Message: Some tweaking of the scope of *gc-running*. Date: Tue Jul 27 06:53:33 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.32 movitz/losp/los0-gc.lisp:1.33 --- movitz/losp/los0-gc.lisp:1.32 Fri Jul 23 09:44:07 2004 +++ movitz/losp/los0-gc.lisp Tue Jul 27 06:53:33 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.32 2004/07/23 16:44:07 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.33 2004/07/27 13:53:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -292,15 +292,15 @@ (let ((*gc-running* t)) (unless *gc-quiet* (format t "~&;; GC.. ")) - (stop-and-copy) - (if *gc-break* - (break "GC break.") - (loop ; This is a nice opportunity to poll the keyboard.. - (case (muerte.x86-pc.keyboard:poll-char) - ((#\esc) - (break "Los0 GC keyboard poll.")) - ((nil) - (return))))))))) + (stop-and-copy)) + (if *gc-break* + (break "GC break.") + (loop ; This is a nice opportunity to poll the keyboard.. + (case (muerte.x86-pc.keyboard:poll-char) + ((#\esc) + (break "Los0 GC keyboard poll.")) + ((nil) + (return)))))))) (let* ((actual-duo-space (or duo-space (allocate-duo-space (* kb-size #x100)))) (last-location (object-location (cons 1 2))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp
by Frode Vatvedt Fjeld 27 Jul '04

27 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6862 Modified Files: interrupt.lisp Log Message: Re-wrote software-interrupt as raise-exception. Date: Tue Jul 27 06:50:08 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.18 movitz/losp/muerte/interrupt.lisp:1.19 --- movitz/losp/muerte/interrupt.lisp:1.18 Wed Jul 21 18:02:22 2004 +++ movitz/losp/muerte/interrupt.lisp Tue Jul 27 06:50:08 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.18 2004/07/22 01:02:22 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.19 2004/07/27 13:50:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -376,31 +376,28 @@ (with-inline-assembly (:returns :nothing) (:sti))) -(define-primitive-function primitive-software-interrupt () - "A primitive code-vector that generates software interrupts." - (macrolet ((make-software-interrupt-code () - (cons 'progn - (loop for vector from 0 to 255 - collect `(with-inline-assembly (:returns :nothing) - ;; Each code-entry is 2+1+1=4 bytes. - ((2) :int ,vector) - ((1) :ret) - ((1) :nop)))))) - (make-software-interrupt-code))) - -(defun software-interrupt (interrupt-vector &optional (eax 0) (ebx 0)) - "Generate software-interrupt number <interrupt-vector>." +(defun raise-exception (exception &optional (eax 0) (ebx 0)) + "Generate a CPU exception, with those values in EAX and EBX." ;; The problem now is that the x86 INT instruction only takes an ;; immediate argument. - ;; Hence the primitive-function primitive-software-interrupt. - (check-type interrupt-vector (unsigned-byte 8)) - (let ((code-vector (symbol-value 'primitive-software-interrupt))) - (check-type code-vector vector) - (with-inline-assembly-case () - (do-case (t :nothing) - (:compile-two-forms (:ecx :edx) interrupt-vector code-vector) - (:leal (:edx :ecx 2) :ecx) - (:compile-two-forms (:eax :ebx) eax ebx) - (:shrl 2 :eax) - (:shrl 2 :ebx) - (:call :ecx))))) + (check-type exception (unsigned-byte 8)) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:load-lexical (:lexical-binding eax) :eax) + (:load-lexical (:lexical-binding ebx) :ebx) + (:load-lexical (:lexical-binding exception) :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:jnz 'not-0) + (:int 0) + (:jmp 'done) + not-0 + ,@(loop for i from 1 to 255 as label = (gensym (format nil "not-~D" i)) + appending + `((:decl :ecx) + (:jnz ',label) + (:int ,i) + ;; (:jmp 'done) + ,label)) + done))) + (do-it)))

1 0

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

27 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6978 Modified Files: integers.lisp Log Message: Some more ratio support. Date: Tue Jul 27 06:47:09 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.82 movitz/losp/muerte/integers.lisp:1.83 --- movitz/losp/muerte/integers.lisp:1.82 Wed Jul 21 15:30:51 2004 +++ movitz/losp/muerte/integers.lisp Tue Jul 27 06:47:09 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.82 2004/07/21 22:30:51 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.83 2004/07/27 13:47:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -681,6 +681,14 @@ (- x (- y))) (((integer * -1) (integer * -1)) (%negatef (+ (- x) (- y)) x y)) + ((ratio t) + (make-rational (+ (* (ratio-numerator x) (denominator y)) + (* (numerator y) (ratio-denominator x))) + (* (ratio-denominator x) (denominator y)))) + ((integer ratio) + (make-rational (+ (* x (denominator y)) + (* (ratio-numerator y) x)) + (denominator y))) ))) (do-it))) (t (&rest terms) @@ -1165,6 +1173,15 @@ (i 0 (+ i 29))) ((>= i length) r) (incf r (ash (* x (ldb (byte 29 i) y)) i))))) + ((ratio ratio) + (make-rational (* (ratio-numerator x) (ratio-numerator y)) + (* (ratio-denominator x) (ratio-denominator x)))) + ((ratio t) + (make-rational (* y (ratio-numerator x)) + (ratio-denominator x))) + ((t ratio) + (make-rational (* x (ratio-numerator y)) + (ratio-denominator y))) ((t (integer * -1)) (%negatef (* x (- y)) x y)) (((integer * -1) t)

1 0

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

27 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv32244 Modified Files: arrays.lisp Log Message: Fixed (setf aref) for u8 and code-vectors. Date: Tue Jul 27 06:46:39 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.40 movitz/losp/muerte/arrays.lisp:1.41 --- movitz/losp/muerte/arrays.lisp:1.40 Wed Jul 21 18:09:44 2004 +++ movitz/losp/muerte/arrays.lisp Tue Jul 27 06:46:39 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.40 2004/07/22 01:09:44 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.41 2004/07/27 13:46:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -367,6 +367,7 @@ ;; u8? (:cmpl ,(movitz:basic-vector-type-tag :u8) :ecx) (:jne 'not-u8-vector) + code-vector (:testl ,(logxor #xffffffff (* #xff movitz:+movitz-fixnum-factor+)) :eax) (:jne '(:sub-program (not-an-u8) @@ -376,9 +377,14 @@ (:movl :edx :ecx) (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) (:movb :ah (:ebx :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) + (:shrl ,(- 8 movitz:+movitz-fixnum-shift+) :eax) (:jmp 'return) not-u8-vector + ;; Code? + (:cmpl ,(movitz:basic-vector-type-tag :code) :ecx) + (:je 'code-vector) + ;; u32? (:cmpl ,(movitz:basic-vector-type-tag :u32) :ecx) (:jne 'not-u32-vector) @@ -390,7 +396,7 @@ not-u32-vector ;; bit? (:cmpl ,(movitz:basic-vector-type-tag :bit) :ecx) - (:jne 'not-u8-vector) + (:jne 'not-bit-vector) (:testl ,(logxor #xffffffff (* #x1 movitz:+movitz-fixnum-factor+)) :eax) (:jne '(:sub-program (not-a-bit)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp
by Frode Vatvedt Fjeld 27 Jul '04

27 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv20068 Modified Files: typep.lisp Log Message: Tuning of the number and rational types. Date: Tue Jul 27 02:22:21 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.32 movitz/losp/muerte/typep.lisp:1.33 --- movitz/losp/muerte/typep.lisp:1.32 Fri Jul 23 08:37:17 2004 +++ movitz/losp/muerte/typep.lisp Tue Jul 27 02:22:21 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.32 2004/07/23 15:37:17 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.33 2004/07/27 09:22:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -179,7 +179,7 @@ (make-other-typep :bignum 0)) ((negative-bignum) (make-other-typep :bignum #xff)) - ((integer number rational) + ((integer) `(with-inline-assembly-case () (do-case (t :boolean-zf=1 :labels (done)) (:compile-form (:result-mode :eax) ,object) @@ -555,8 +555,11 @@ (typep x 'bignum)) (define-simple-typep (number numberp) (x) - "Currently, only integer numbers are supported." - (integerp x)) + "Currently, only integers and ratios are supported." + (or (typep x 'fixnum) + (and (typep x 'tag6) + (or (typep x 'bignum) + (ratio-p x))))) (define-simple-typep (function functionp) (x) (typep x 'function))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp
by Frode Vatvedt Fjeld 27 Jul '04

27 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27552 Modified Files: inspect.lisp Log Message: More defstruct fixes. Structs now have a class slot, not a name slot. And, let's allow a :superclass option for defstruct. Date: Tue Jul 27 02:19:14 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.31 movitz/losp/muerte/inspect.lisp:1.32 --- movitz/losp/muerte/inspect.lisp:1.31 Fri Jul 23 08:36:46 2004 +++ movitz/losp/muerte/inspect.lisp Tue Jul 27 02:19:14 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.31 2004/07/23 15:36:46 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.32 2004/07/27 09:19:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -245,7 +245,7 @@ (test cdr))) (structure-object (and (typep y 'structure-object) - (test structure-object-name) + (test structure-object-class) (test structure-object-length) (dotimes (i (structure-object-length x) t) (unless (test structure-ref i)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/defstruct.lisp
by Frode Vatvedt Fjeld 27 Jul '04

27 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27426 Modified Files: defstruct.lisp Log Message: More defstruct fixes. Structs now have a class slot, not a name slot. And, let's allow a :superclass option for defstruct. Date: Tue Jul 27 02:19:09 2004 Author: ffjeld Index: movitz/losp/muerte/defstruct.lisp diff -u movitz/losp/muerte/defstruct.lisp:1.11 movitz/losp/muerte/defstruct.lisp:1.12 --- movitz/losp/muerte/defstruct.lisp:1.11 Fri Jul 23 18:30:44 2004 +++ movitz/losp/muerte/defstruct.lisp Tue Jul 27 02:19:09 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jan 22 13:10:59 2001 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defstruct.lisp,v 1.11 2004/07/24 01:30:44 ffjeld Exp $ +;;;; $Id: defstruct.lisp,v 1.12 2004/07/27 09:19:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -23,6 +23,9 @@ (check-type object structure-object) (memref object -4 0 :unsigned-byte14)) +(defun structure-object-class (x) + (memref x -6 1 :lisp)) + (defun copy-structure (object) ;; (check-type object structure-object) (let* ((length (structure-object-length object)) @@ -167,6 +170,7 @@ ((cons symbol (cons * null)) (let ((parameter (second option))) (ecase (car option) + (:superclass (push parameter (getf collector :superclass))) (:conc-name (push (string (or parameter "")) (getf collector :conc-name))) (:constructor (push parameter (getf collector :constructor))) @@ -194,6 +198,7 @@ (assert (<= 1 (length (getf options ,option)) ,max-values) () "Option ~S given too many times." ,option)))) (default (:type 1) 'class-struct) + (default (:superclass 1) 'structure-object) (default (:named 1) nil) (default (:conc-name 1) (concatenate 'string (string struct-name) (string #\-))) @@ -202,9 +207,15 @@ (default (:predicate 1) (intern (concatenate 'string (string struct-name) (string '-p))))) (let* ((struct-type (first (getf options :type))) + (superclass (first (getf options :superclass))) (struct-named (first (getf options :named))) (conc-name (first (getf options :conc-name))) (predicate-name (first (getf options :predicate))) + (standard-name-and-options (if (not (consp name-and-options)) + name-and-options + (remove :superclass name-and-options + :key (lambda (x) + (when (consp x) (car x)))))) (canonical-slot-descriptions (mapcar #'(lambda (d) "(<slot-name> <init-form> <type> <read-only-p> <initarg>)" @@ -224,9 +235,9 @@ (setf (gethash '(:translate-when :eval ,struct-name :cl :muerte.cl) (movitz::image-struct-slot-descriptions movitz:*image*)) '(:translate-when :eval ,slot-descriptions :cl :muerte.cl)) - (defstruct (:translate-when :eval ,name-and-options :cl :muerte.cl) + (defstruct (:translate-when :eval ,standard-name-and-options :cl :muerte.cl) . (:translate-when :eval ,slot-names :cl :muerte.cl))) - (defclass ,struct-name (structure-object) () + (defclass ,struct-name (,superclass) () (:metaclass structure-class) (:slots ,(loop for (name) in canonical-slot-descriptions as location upfrom 0 @@ -334,6 +345,5 @@ ',struct-name)) )))))) -;;;(defun structure-object-name (x) -;;; (movitz-accessor x movitz-struct name)) +

1 0

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

27 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv23572 Modified Files: storage-types.lisp Log Message: Added a print-object method for movitz-basic-vectors. Date: Tue Jul 27 02:13:36 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.32 movitz/storage-types.lisp:1.33 --- movitz/storage-types.lisp:1.32 Fri Jul 23 18:30:40 2004 +++ movitz/storage-types.lisp Tue Jul 27 02:13:36 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.32 2004/07/24 01:30:40 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.33 2004/07/27 09:13:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -363,9 +363,19 @@ :binary-lisp-type :label) ; data follows physically here (symbolic-data :initarg :symbolic-data + :initform nil :accessor movitz-vector-symbolic-data)) (:slot-align type #.+other-type-offset+)) +(defmethod print-object ((object movitz-basic-vector) stream) + (cond + ((eq :character (movitz-vector-element-type object)) + (print-unreadable-object (object stream :type t :identity nil) + (write (map 'string #'identity (movitz-vector-symbolic-data object)) + :stream stream)) + object) + (t (call-next-method)))) + (defun vector-type-tag (element-type) (dpb (enum-value 'movitz-vector-element-type element-type) (byte 8 8)

1 0

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

27 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv8643 Modified Files: image.lisp Log Message: Try to make sure that the segment-descriptor-table is 16-aligned. Date: Tue Jul 27 02:11:44 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.51 movitz/image.lisp:1.52 --- movitz/image.lisp:1.51 Fri Jul 23 18:30:27 2004 +++ movitz/image.lisp Tue Jul 27 02:11:44 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.51 2004/07/24 01:30:27 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.52 2004/07/27 09:11:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -408,6 +408,9 @@ (declare (ignore x type)) (- (bt:slot-offset 'movitz-constant-block 'non-pointers-end) (bt:slot-offset 'movitz-constant-block 'non-pointers-start)))) + (bochs-flags + :binary-type lu32 + :initform 0) (non-pointers-start :binary-type :label) ; ========= NON-POINTER-START ======= ;; (align-segment-descriptors :binary-type 4) (segment-descriptor-table :binary-type :label) @@ -446,13 +449,9 @@ (segment-descriptor-7 :binary-type segment-descriptor :initform (make-segment-descriptor)) - (bochs-flags - :binary-type lu32 - :initform 0) (scratch0 ; A non-GC-root scratch register :binary-type lu32 :initform 0) - (non-pointers-end :binary-type :label) ; ========= NON-POINTER-END ======= (atomically-status @@ -795,6 +794,10 @@ (ldb (byte 3 0) (image-nil-word *image*)) (tag :null)) (setf (image-constant-block *image*) (make-movitz-constant-block)) + (unless (= 0 (mod (+ (image-nil-word *image*) (slot-offset 'movitz-constant-block + 'segment-descriptor-table)) + 16)) + (warn "Segment descriptor table is not aligned on a 16-byte boundary.")) (setf (movitz-constant-block-interrupt-descriptor-table (image-constant-block *image*)) (movitz-read (make-initial-interrupt-descriptors))) (setf (image-t-symbol *image*) (movitz-read t))

1 0