[movitz-cvs] CVS update: movitz/losp/los0.lisp

[Frode Vatvedt Fjeld]

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

Modified Files:
	los0.lisp 
Log Message:
*** empty log message ***
Date: Tue Jan  4 21:24:00 2005
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.35 movitz/losp/los0.lisp:1.36
--- movitz/losp/los0.lisp:1.35	Wed Dec 15 14:58:26 2004
+++ movitz/losp/los0.lisp	Tue Jan  4 21:24:00 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2000-2004,
+;;;;    Copyright (C) 2000-2005,
 ;;;;    Department of Computer Science, University of Tromso, Norway
 ;;;; 
 ;;;; Filename:      los0.lisp
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.35 2004/12/15 13:58:26 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.36 2005/01/04 20:24:00 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -108,6 +108,38 @@
 ;;;  (declare (dynamic-extent args))
 ;;;  (apply (constantly 'test-value) args))
 
+(defun test-closure (x z)
+  (flet ((closure (y) (= x (1+ y))))
+    (declare (dynamic-extent (function closure)))
+    (closure z)
+    #+ignore (funcall (lambda (y) (= x (1+ y)))
+		      z)))
+
+(defun test-stack-cons (x y)
+  (muerte::with-dynamic-extent-scope (zap)
+    (let ((foo (muerte::with-dynamic-extent-allocation (zap)
+		 (cons x (lambda () y)))))
+      (format t "~Z: ~S, ~S" foo foo (funcall (cdr foo))))))
+
+(defun test-handler (x)
+  (let ((foo x))
+    (handler-bind
+	((error (lambda (c)
+		  (format t "error: ~S ~S" c x))))
+      (error "This is an error. ~S" foo))))
+
+(defun fooo (v w)
+  (tagbody
+    (print (block blurgh
+	     (progv (list v) (list w)
+	       (format t "Uh: ~S" (symbol-value v))
+	       (if (symbol-value v)
+		   (return-from blurgh 1)
+		 (go zap)))))
+   zap)
+  t)
+
+
 (defun test-break ()
   (with-inline-assembly (:returns :multiple-values)
     (:movl 10 :ecx)
@@ -544,14 +576,6 @@
 (defun test-fixed (x y z)
   (warn "x: ~W, y: ~W, z: ~W" x y z))
 
-(defun test-closure (x)
-  (warn "lending x: ~W" x)
-  (values (lambda ()
-	    (warn "borrowed x: ~W" x)
-	    (* x 2))
-	  (lambda (y)
-	    (setq x y))))
-
 (defun test-let-closure ()
   (tagbody
     (let ((*print-base* 10)
@@ -1089,6 +1113,28 @@
 	(with-simple-restart (abort "Abort to command level ~D." (1+ *repl-level*))
 	  (read-eval-print))))))
 
+(defun xwrite (object)
+  (with-inline-assembly (:returns :nothing)
+    (:locally (:movl (:edi (:edi-offset muerte::dynamic-env)) :eax))
+    (:movl :eax (#x1000000))
+    (:movl :ebp (#x1000004))
+    (:movl :esi (#x1000008)))
+  (block handler-case-block-1431896
+    (let (handler-case-var-1431897)
+      (tagbody
+	(handler-bind
+	    ((serious-condition
+	      (lambda (handler-case-temp-var-1431898)
+		(setq handler-case-var-1431897 handler-case-temp-var-1431898)
+		(go handler-case-clause-tag-1431899))))
+	  (return-from handler-case-block-1431896
+	    (muerte::internal-write object)))
+       handler-case-clause-tag-1431899
+	(return-from handler-case-block-1431896
+	  (let ((c handler-case-var-1431897))
+	    (print-unreadable-object (c *standard-output* :type t :identity t)
+	      (format t " while printing ~z" object))))))))
+
 (defun ub (x)
   `(hello world ,x or . what))
 
@@ -1185,7 +1231,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."))
@@ -1219,8 +1265,7 @@
 	    *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))))
-      
-      #+ignore (muerte::sti)))
+      (muerte::sti)))
   (with-inline-assembly (:returns :nothing)
     (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*)
     (:shrl 2 :ecx)
@@ -1259,7 +1304,7 @@
 			 (progn
 ;;;			   (unless (logbitp 9 (eflags))
 ;;;			     (break "Someone switched off interrupts!"))
-			   (incf (memref-int muerte.x86-pc::*screen* :type :unsigned-byte16))
+;;;			   (incf (memref-int muerte.x86-pc::*screen* :type :unsigned-byte16))
 			   (throw 'foo 'inner-peace))
 		       (incf (memref-int muerte.x86-pc::*screen* :index 80 :type :unsigned-byte16)))))
 	(incf (memref-int muerte.x86-pc::*screen* :index 160 :type :unsigned-byte16))))))
@@ -1305,8 +1350,8 @@
     (format t "Extended memory: ~D KB~%" extended-memsize)
 
     (idt-init)
-    #+ignore
     (install-los0-consing :kb-size 500)
+    #+ignore
     (install-los0-consing :kb-size (max 100 (truncate (- extended-memsize 2048) 2))))
 
   (setf *debugger-function* #'los0-debugger)