Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv7945

Modified Files: los0.lisp Log Message: *** empty log message *** Date: Wed Mar 9 08:24:55 2005 Author: ffjeld

Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.36 movitz/losp/los0.lisp:1.37 --- movitz/losp/los0.lisp:1.36 Tue Jan 4 21:24:00 2005 +++ movitz/losp/los0.lisp Wed Mar 9 08:24:54 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.36 2005/01/04 20:24:00 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.37 2005/03/09 07:24:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -20,6 +20,7 @@ (require :x86-pc/io-space) (require :x86-pc/ne2k) (require :x86-pc/floppy) +(require :x86-pc/serial)

(require :lib/readline) (require :lib/toplevel) @@ -40,7 +41,7 @@ ;; #:muerte.ip6 #:muerte.ip4 #:muerte.mop - #+ignore muerte.x86-pc.serial)) + #:muerte.x86-pc.serial))

(require :los0-gc) ; Must come after defpackage.

@@ -1011,7 +1012,8 @@ (if (not (and (boundp '*debugger-condition*) *debugger-condition*)) (fresh-line) - (let ((condition *debugger-condition*)) + (let ((condition *debugger-condition*) + (*print-safely* t)) (cond ((consp condition) (fresh-line) @@ -1141,7 +1143,7 @@ (defun random (limit) (etypecase limit (fixnum - (rem (read-time-stamp-counter) limit)) + (mod (read-time-stamp-counter) limit)) (muerte::positive-bignum (let ((x (muerte::copy-bignum limit))) (dotimes (i (1- (muerte::%bignum-bigits x))) @@ -1210,8 +1212,9 @@ (assert (string= fasit x) () "Failed tesT. Fasit: ~S, X: ~S" fasit x)))))

-(defun test-clc (&optional timeout) - (test-timer timeout) +(defun test-clc (&optional timeout no-timer) + (unless no-timer + (test-timer timeout)) (loop (funcall (find-symbol (string :test-clc) :clc))))

@@ -1231,7 +1234,7 @@ ;;; (vector-push funobj ts) ;;; (vector-push offset ts) ;;; (vector-push code-vector ts)))) - (muerte::cli) +;;; (muerte::cli) (pic8259-end-of-interrupt 0) (when (eql #\esc (muerte.x86-pc.keyboard:poll-char)) (break "Test-timer keyboard break.")) @@ -1246,12 +1249,11 @@ (when (eq (with-inline-assembly (:returns :eax) (:movl :esi :eax)) (stack-frame-funobj nil frame)) (error "Double interrupt."))) - #+ignore - (dolist (range muerte::%memory-map-roots%) - (map-header-vals (lambda (x type) - (declare (ignore type)) - x) - (car range) (cdr range))) +;;; (dolist (range muerte::%memory-map-roots%) +;;; (map-header-vals (lambda (x type) +;;; (declare (ignore type)) +;;; x) +;;; (car range) (cdr range))) (map-stack-vector (lambda (x foo) (declare (ignore foo)) x) @@ -1261,11 +1263,12 @@ (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*) (:shrl 2 :ecx) ((:gs-override) :movb #x20 (:ecx 159))) - (setf *timer-prevstack* *timer-stack* - *timer-stack* (muerte::copy-current-control-stack)) + #+ignore (setf *timer-prevstack* *timer-stack* + *timer-stack* (muerte::copy-current-control-stack)) (setf (pit8253-timer-mode 0) +pit8253-mode-single-timeout+ (pit8253-timer-count 0) (or timeout (+ base (random variation)))) - (muerte::sti))) +;;; (muerte::sti) + )) (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*) (:shrl 2 :ecx) @@ -1274,24 +1277,10 @@ (pit8253-timer-count 0) (or timeout (+ base (random variation)))) (setf (pic8259-irq-mask) #xfffe) (pic8259-end-of-interrupt 0) - (with-inline-assembly (:returns :nothing) (:sti)) - ;; (dotimes (i 100000)) - #+ignore - (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:ebx :edx) - (read-time-stamp-counter) - (read-time-stamp-counter)) - (:movl :eax (#x1000000)) - (:movl :ebx (#x1000004)) - (:movl :ecx (#x1000008)) - (:movl :edx (#x100000c)) - (:movl :ebp (#x1000010)) - (:movl :esp (#x1000014)) - (:movl :esi (#x1000018)) - (:halt) - (:cli) - (:halt) - )) + (with-inline-assembly (:returns :nothing) (:sti))) + +(defun wetweg (x) + (memref-int (memref x 2 :type :unsigned-byte32) :physicalp nil :type :unsigned-byte8))

(defun test-throwing (&optional (x #xffff)) (when x @@ -1338,7 +1327,7 @@ (:jno 'no-overflow) (:movl 4 :eax) no-overflow)) - + (defun genesis () ;; (install-shallow-binding) (let ((extended-memsize 0)) @@ -1352,10 +1341,11 @@ (idt-init) (install-los0-consing :kb-size 500) #+ignore - (install-los0-consing :kb-size (max 100 (truncate (- extended-memsize 2048) 2)))) + (install-los0-consing :kb-size (max 50 (truncate (- extended-memsize 2048) 2))))

(setf *debugger-function* #'los0-debugger) (clos-bootstrap) + (install-shallow-binding) (let ((*repl-readline-context* (make-readline-context :history-size 16)) #+ignore (*backtrace-stack-frame-barrier* (stack-frame-uplink (current-stack-frame))) #+ignore (*error-no-condition-for-debugger* t) @@ -1385,6 +1375,10 @@ *standard-input* s *terminal-io* s *debug-io* s))) +;;; (ignore-errors +;;; (setf (symbol-function 'write-char) +;;; (muerte.x86-pc.serial::make-serial-write-char :baudrate 38400)) +;;; (format t "~&Installed serial-port write-char.")) (let ((* nil) (** nil) (*** nil) (/ nil) (// nil) (/// nil) (+ nil) (++ nil) (+++ nil) @@ -1409,41 +1403,6 @@ (let ((string (muerte.readline:contextual-readline *repl-readline-context*))) (simple-read-from-string string eof-error-p eof-value)))

-(defun handle-warning (condition) - (format t "Handle-warning: ~S" condition) - (throw :debugger nil)) - -(defun zoo (x) - (cond - (x (warn "foo")) - (t nil)) - nil) - -#+ignore -(defun progntest () - (prog () - (unwind-protect - (progn - (print 'x) - (go mumbo) - (error "bar")) - (print 'y)) - mumbo)) - -#+ignore -(defun test-restart (x) - (with-simple-restart (test "It's just a test, so ignore ~S." x) - (check-type x symbol))) - -#+ignore -(defun condtest () - (format t "You have two attempts..") - (handler-bind - ((error #'(lambda (c) (print 'x) (warn "An error occurred.."))) - (warning #'handle-warning) - (t #'invoke-debugger)) - (read-eval-print) - (read-eval-print)))

#+ignore (defun ztstring (physical-address)