[Mit-cadr-cvs] r299 - trunk/lisp/io

[rswindells at common-lisp.net]

Author: rswindells
Date: Sat May  5 09:11:35 2012
New Revision: 299

Log:
Add DEBUG-STREAM implementation.

Added:
   trunk/lisp/io/debug.lisp

Added: trunk/lisp/io/debug.lisp
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ trunk/lisp/io/debug.lisp	Sat May  5 09:11:35 2012	(r299)
@@ -0,0 +1,104 @@
+;;; -*- Mode:LISP; Package:SI; Base:8 -*-
+;	** (c) Copyright 1980 Massachusetts Institute of Technology **
+
+;;; This file contains a stream to write to a debug port.
+;;; 
+;;; derived from WINDOW>COLD
+
+(DEFINSTANCE-IMMEDIATE DEBUG-STREAM
+  CURSOR-X					;Current x position
+  CURSOR-Y					;Current y position
+  TV:CONTROL-ADDRESS				;Hardware controller address
+  UNRCHF					;For :UNTYI
+  )
+
+(DEFMETHOD-IMMEDIATE (DEBUG-STREAM :PRINT-SELF) (STREAM &REST IGNORE)
+  (FORMAT STREAM "#<~A ~O>" (TYPEP SELF) (%POINTER SELF)))
+
+(DEFMETHOD-IMMEDIATE (DEBUG-STREAM :INIT) (PLIST)
+  (SETQ CURSOR-X 0 CURSOR-Y 0
+	UNRCHF NIL
+	TV:CONTROL-ADDRESS (GET PLIST ':CONTROL-ADDRESS)))
+
+;(DEFMETHOD-IMMEDIATE (DEBUG-STREAM :READ-CURSORPOS) (&OPTIONAL (UNITS ':PIXEL)
+;					       &AUX (X CURSOR-X) (Y CURSOR-Y))
+;  (AND (EQ UNITS ':CHARACTER)
+;       (SETQ X (// X CHAR-WIDTH)
+;	     Y (// Y LINE-HEIGHT)))
+;  (PROG () (RETURN X Y)))
+
+(DEFMETHOD-IMMEDIATE (DEBUG-STREAM :SET-CURSORPOS) (X Y)
+  (SETQ CURSOR-X X CURSOR-Y Y))
+
+(DEFMETHOD-IMMEDIATE (DEBUG-STREAM :HOME-CURSOR) ()
+  (SETQ CURSOR-X 0 CURSOR-Y 0))
+
+(DEFMETHOD-IMMEDIATE (DEBUG-STREAM :HANDLE-EXCEPTIONS) ())
+
+(DEFMETHOD-IMMEDIATE (DEBUG-STREAM :TYO) (CH)
+  (COND ((< CH 200)
+	 (%XBUS-WRITE 377000 CH))
+;	((= CH #\TAB)
+;	   (DOTIMES (I (- 8 (\ (// CURSOR-X CHAR-WIDTH) 8)))
+;	     (FUNCALL-SELF ':TYO #\SP)))
+	((= CH #\CR)
+	 (%XBUS-WRITE 377000 12)
+	 (FUNCALL-SELF ':CLEAR-EOL)))
+  CH)
+
+(DEFMETHOD-IMMEDIATE (DEBUG-STREAM :CLEAR-EOL) ())
+
+(DEFMETHOD-IMMEDIATE (DEBUG-STREAM :CLEAR-SCREEN) ()
+  (SETQ CURSOR-X 0 CURSOR-Y 0))
+
+(DEFMETHOD-IMMEDIATE (DEBUG-STREAM :FRESH-LINE) ()
+  (IF (ZEROP CURSOR-X) (FUNCALL-SELF ':CLEAR-EOL)
+      (FUNCALL-SELF ':TYO #\CR)))
+
+(DEFMETHOD-IMMEDIATE (DEBUG-STREAM :STRING-OUT) (STRING &OPTIONAL (START 0) END)
+  (DO ((I START (1+ I))
+       (END (OR END (ARRAY-ACTIVE-LENGTH STRING))))
+      ((
 I END))
+    (FUNCALL-SELF ':TYO (AREF STRING I))))
+
+(DEFMETHOD-IMMEDIATE (DEBUG-STREAM :LINE-OUT) (STRING &OPTIONAL (START 0) END)
+  (FUNCALL-SELF ':STRING-OUT STRING START END)
+  (FUNCALL-SELF ':TYO #\CR))
+
+;(DEFMETHOD-IMMEDIATE (DEBUG-STREAM :UNTYI) (CH)
+;  (SETQ UNRCHF CH))
+
+;(DEFMETHOD-IMMEDIATE (DEBUG-STREAM :LISTEN) ()
+;  (OR UNRCHF
+;      (DO () ((NOT (KBD-HARDWARE-CHAR-AVAILABLE)) NIL)
+;	(AND (SETQ UNRCHF (KBD-CONVERT-TO-SOFTWARE-CHAR (KBD-GET-HARDWARE-CHAR)))
+;	     (RETURN T)))))
+
+;(DEFMETHOD-IMMEDIATE (DEBUG-STREAM :TYI) (&AUX IDX (INHIBIT-SCHEDULING-FLAG T))
+;  (COND (UNRCHF
+;	 (PROG1 UNRCHF (SETQ UNRCHF NIL)))
+;	((NOT RUBOUT-HANDLER)
+;	 (DO () (())
+;	   (LET ((CHAR (KBD-CONVERT-TO-SOFTWARE-CHAR (KBD-GET-HARDWARE-CHAR))))
+;	     (SELECTQ CHAR
+;	       (NIL)				;Unreal character
+;	       (#\BREAK (BREAK T))
+;	       (OTHERWISE (RETURN CHAR))))))
+;	((> (ARRAY-LEADER RUBOUT-HANDLER-BUFFER 0)
+;	    (SETQ IDX (ARRAY-LEADER RUBOUT-HANDLER-BUFFER 1)))
+;	 (STORE-ARRAY-LEADER (1+ IDX) RUBOUT-HANDLER-BUFFER 1)
+;	 (AREF RUBOUT-HANDLER-BUFFER IDX))
+;	(T
+;	 (DEBUG-STREAM-RUBOUT-HANDLER))))
+
+;(DEFMETHOD-IMMEDIATE (DEBUG-STREAM :TYI-NO-HANG) ()
+;  (AND (FUNCALL-SELF ':LISTEN)
+;       (FUNCALL-SELF ':TYI)))
+
+(DECLARE-INSTANCE-IMMEDIATE-INSTANCE-VARIABLES (DEBUG-STREAM))
+
+

+
+(MAKE-INSTANCE-IMMEDIATE DEBUG-STREAM
+			 :CONTROL-ADDRESS 377000)
+