Changeset 288

Timestamp:

08/18/11 11:30:58 (21 months ago)

Author:

rjs

Message:

Update from System 78.

Location:

trunk/lisp/lmio1

Files:

• as8748.lisp (added)
• cdrive.lisp (modified) (5 diffs)
• chatst.lisp (modified) (20 diffs)
• colhak.lisp (deleted)
• ctest.lisp (modified) (3 diffs)
• cvpts.lisp (deleted)
• dplt.lisp (deleted)
• dplt.pkg (deleted)
• draw.lisp (deleted)
• eftp.lisp (modified) (7 diffs)
• escape.lisp (deleted)
• fcmp.lisp (deleted)
• fed.lisp (deleted)
• fntcnv.lisp (modified) (17 diffs)
• fntdef.lisp (modified) (3 diffs)
• fquery.lisp (added)
• hacks.lisp (deleted)
• load.paint (deleted)
• menu.lisp (deleted)
• meter.lisp (added)
• mouse.lisp (deleted)
• npaint.lisp (deleted)
• output.lisp (added)
• paint.lisp (deleted)
• press.lisp (modified) (20 diffs)
• promp.lisp (modified) (7 diffs)
• qfile.lisp (deleted)
• redo.lisp (deleted)
• reldmp.lisp (modified) (2 diffs)
• relld.lisp (modified) (1 diff)
• rfontw.lisp (modified) (10 diffs)
• serial.lisp (modified) (1 diff)
• srccom.lisp (added)
• supser.lisp (deleted)
• tablet.lisp (deleted)
• time.lisp (modified) (9 diffs)
• timpar.lisp (added)
• ukbd.lisp (added)
• versat.lisp (deleted)
• vm.lisp (deleted)
• votrax.lisp (deleted)
• wlr.doc (deleted)
• words.lisp (deleted)
• xfed.lisp (deleted)
• xgp.lisp (modified) (7 diffs)

trunk/lisp/lmio1/cdrive.lisp

@@ +1 @@
+
 ;;-*- MODE: LISP; PACKAGE: USER; -*-
 
@@ -341 +342 @@
     (PROG NIL
           (IF (= (LDB 0003 (%UNIBUS-READ 764102)) 1)    ;Last character new keyboard?
-            (SELECTQ CH0                        ;Yes, same keys but different glyphs
-              (#/( (RETURN (* -STEP MULTIPLIER) 0))
-              (#/[ (RETURN (FIX (* -STEP BIGMULT MULTIPLIER)) 0))
-              (#/) (RETURN (* STEP MULTIPLIER) 0))
-              (#/] (RETURN (FIX (* STEP BIGMULT MULTIPLIER)) 0))
-              (#/` (RETURN 0 (* STEP MULTIPLIER)))
-              (#/~ (RETURN 0 (FIX (* STEP BIGMULT MULTIPLIER))))
-              (#/\ (RETURN 0 (* -STEP MULTIPLIER)))
-              (#/| (RETURN 0 (FIX (* -STEP BIGMULT MULTIPLIER)))))
-            (SELECTQ CH0
-              (#/[ (RETURN (* -STEP MULTIPLIER) 0))
-              (#/{ (RETURN (FIX (* -STEP BIGMULT MULTIPLIER)) 0))
-              (#/] (RETURN (* STEP MULTIPLIER) 0))
-              (#/} (RETURN (FIX (* STEP BIGMULT MULTIPLIER)) 0))
-              (#/\ (RETURN 0 (* STEP MULTIPLIER)))
-              (#/| (RETURN 0 (FIX (* STEP BIGMULT MULTIPLIER))))
-              (#// (RETURN 0 (* -STEP MULTIPLIER)))
-              (#/ (RETURN 0 (FIX (* -STEP BIGMULT MULTIPLIER))))))
+              (SELECTQ CH0                      ;Yes, same keys but different glyphs
+                (#/( (RETURN (* -STEP MULTIPLIER) 0))
+                (#/[ (RETURN (FIX (* -STEP BIGMULT MULTIPLIER)) 0))
+                (#/) (RETURN (* STEP MULTIPLIER) 0))
+                (#/] (RETURN (FIX (* STEP BIGMULT MULTIPLIER)) 0))
+                (#/` (RETURN 0 (* STEP MULTIPLIER)))
+                (#/~ (RETURN 0 (FIX (* STEP BIGMULT MULTIPLIER))))
+                (#/\ (RETURN 0 (* -STEP MULTIPLIER)))
+                (#/| (RETURN 0 (FIX (* -STEP BIGMULT MULTIPLIER)))))
+              (SELECTQ CH0
+                (#/[ (RETURN (* -STEP MULTIPLIER) 0))
+                (#/{ (RETURN (FIX (* -STEP BIGMULT MULTIPLIER)) 0))
+                (#/] (RETURN (* STEP MULTIPLIER) 0))
+                (#/} (RETURN (FIX (* STEP BIGMULT MULTIPLIER)) 0))
+                (#/\ (RETURN 0 (* STEP MULTIPLIER)))
+                (#/| (RETURN 0 (FIX (* STEP BIGMULT MULTIPLIER))))
+                (#// (RETURN 0 (* -STEP MULTIPLIER)))
+                (#/ (RETURN 0 (FIX (* -STEP BIGMULT MULTIPLIER))))))
           (RETURN NIL))))
 
@@ -624 +625 @@
   (SETQ YPOS-STEPS (+ STEPS YPOS-STEPS)))
 
-(DEFMETHOD (PROBE-CLASS :CALIBRATE) ()
-  (PROG (XD YD REDO-CALIB NBOARDS POS)
-        (FORMAT T "~%REDO CALIBRATOR?")
-        (COND ((SETQ REDO-CALIB (Y-OR-N-P))
+(DEFMETHOD (PROBE-CLASS :CALIBRATE) (&OPTIONAL POS NBOARDS NO-ASK)
+  (PROG (XD YD REDO-CALIB NEXT-POS)
+        (IF (NULL POS)
+            (SETQ POS (SELECTQ CTEST-BOARD-TYPE
+                        (MPG216 "1A01-10")
+                        (LG684 "A1-10"))))
+        (COND ((SETQ REDO-CALIB (OR NO-ASK
+                                    (FQUERY FORMAT:Y-OR-N-P-OPTIONS
+                                            "~%REDO CALIBRATOR?")))
                (<- CALIBRATOR ':INITIALIZE)))
         (COND ((NULL MILLS-TO-STEPS)
                (SETQ MILLS-TO-STEPS (// 1434. (FLOAT (* 5 MPG216-GXOFST))))))
-        (FORMAT T (SELECTQ CTEST-BOARD-TYPE
-                    (MPG216 "~%Position ~S probe over 1A01-10")
-                    (LG684 "~%Position ~S probe over A1-10"))
-                    NAME)
-        (<- SELF ':MANUAL-CONTROL)
-        (<- SELF ':probe-up)
-        (COND ((Y-OR-N-P "RECOMPUTE MILLS-TO-STEPS?")
-               (<- self ':manual-control)
-               (FORMAT T (SELECTQ CTEST-BOARD-TYPE
-                           (MPG216 "~%Now position it over 1F01-10")
-                           (LG684 "~%Now position it over A30-10")))
+        (FORMAT T "~%Position ~S probe over ~A" NAME POS)
+        (COND ((NOT NO-ASK)
+               (<- SELF ':MANUAL-CONTROL)
+               (<- SELF ':PROBE-UP)
+               (COND ((Y-OR-N-P "RECOMPUTE MILLS-TO-STEPS?")
+                      (<- SELF ':MANUAL-CONTROL)
+                      (SETQ NEXT-POS (SELECTQ CTEST-BOARD-TYPE
+                                       (MPG216 "1F01-10")
+                                       (LG684 "A30-10")))
+                      (FORMAT T "~%Now position it over ~A" NEXT-POS)
                (<- SELF ':probe-up)
                (MULTIPLE-VALUE (XD YD) (<- self ':manual-control ctest-slow-speed))
@@ -649 +654 @@
                                                (MPG216 (* 5 MPG216-GXOFST))
                                                (LG684 (* 30. LG684-XDIPSP))))))
-               (SETQ POS (SELECTQ CTEST-BOARD-TYPE
-                           (MPG216 "1F01-10")
-                           (LG684 "A30-10")))
-               (<- SELF ':DEFINE-POSITION-STRING-LOC POS))
-              (T (SETQ POS (SELECTQ CTEST-BOARD-TYPE
-                             (MPG216 "1A01-10")
-                             (LG684 "A1-10"))) 
-                 (<- SELF ':DEFINE-POSITION-STRING-LOC POS)))
+               (SETQ POS NEXT-POS)))))
+        (<- SELF ':DEFINE-POSITION-STRING-LOC POS)
         (COND (REDO-CALIB
                (SELECTQ CTEST-BOARD-TYPE
                  (MPG216
-                  (FORMAT T "~%HOW MANY BOARDS?")
-                  (SETQ NBOARDS (READ))
+                  (IF (NULL NBOARDS)
+                      (PROGN (FORMAT T "~%HOW MANY BOARDS?")
+                             (SETQ NBOARDS (READ))))
                   (DOTIMES (C NBOARDS)
                     (CALIBRATE-AT-LOC (1+ C) (FORMAT NIL "~DA1-10" (1+ C)) CALIBRATOR)
@@ -724 +724 @@
           NAME (<- CALIBRATOR ':CALIBRATION-POINTS)))
   
+
 (DEFUN CTEST-CALIBRATE NIL 
-  (<- LEFT-PROBE ':CALIBRATE)
-  (<- RIGHT-PROBE ':CALIBRATE))
+  (<- RIGHT-PROBE ':CALIBRATE)
+  (<- RIGHT-PROBE ':STEP-X -400)                ;clear field
+  (<- LEFT-PROBE ':CALIBRATE))
+
+(DEFUN TEST-ICMEM (&OPTIONAL NO-CAL)
+  (IF (NULL NO-CAL) (SETUP 2))
+  (SETQ CTEST-BAD-RUNS NIL)
+  (CTEST-PROCESS-WLR "CADRWD;ICMEM3 WLR"))
+
+(DEFUN TEST-CADR (&OPTIONAL NO-CAL)
+  (IF (NULL NO-CAL) (SETUP 4))
+  (SETQ CTEST-BAD-RUNS NIL)
+  (CTEST-PROCESS-WLR "CADRWD;CADR4 WLR"))
+
+(DEFUN SETUP (NBOARDS)
+  (FQUERY FORMAT:Y-OR-N-P-OPTIONS
+          "~% Is the right probe over 1A01-10 and the left probe over 1AJ1-1?")
+  (SETUP-RIGHT NBOARDS "1A01-10")
+  (SETUP-LEFT NBOARDS  "1AJ1-1"))
+
+(DEFUN SETUP-RIGHT (NBOARDS &OPTIONAL (POS "1A01-10"))
+  (<- RIGHT-PROBE ':CALIBRATE POS NBOARDS T)
+  (<- RIGHT-PROBE ':STEP-X -400))               ;clear field
+
+(DEFUN SETUP-LEFT (NBOARDS &OPTIONAL (POS "1A01-10"))
+  (<- LEFT-PROBE ':CALIBRATE POS NBOARDS T))
 
 (DEFUN PRINT-CALIBRATION NIL

trunk/lisp/lmio1/chatst.lisp

@@ -20 +20 @@
 ;;;                          debugging in order for interrupts to work!
 
+(DEFVAR CHATST-USE-DEBUG NIL)   ;if T, everything refers to machine on debug interface
+(DEFVAR CHATST-PACKET-LENGTH 20)        ;Packet length chatst sends
+
 ;;;  **** NOTE *****
 ;;;  Here are some typical screws encountered in testing chaos boards:
@@ -58 +61 @@
 
 
+(DEFMACRO INITIATE-PACKET-TRANSMISSION ()
+  '(%U-READ INITIATE-TRANSFER-REGISTER-TEST))
+
 (DEFUN SET-BASE-ADDRESS (&OPTIONAL (BASE-ADDRESS 764140))
     "Set the base UNIBUS address for the Chaos net device.
@@ -73 +79 @@
           INTERVAL-TIMER-REGISTER-TEST
           (+ BASE-ADDRESS 20))
-    (FORMAT T "~%My number: ~O" (setq chatst-address (%unibus-read MY-NUMBER-REGISTER-TEST))))
-
-(SET-BASE-ADDRESS)
+    (FORMAT T "~%My number: ~O" (setq chatst-address (%u-read MY-NUMBER-REGISTER-TEST))))
 
 (DEFVAR CHATST-PATTERN (MAKE-ARRAY NIL 'ART-16B 256.))
@@ -83 +87 @@
 (DEFUN SET-PATTERN (PAT)
   (SETQ CHATST-PATTERN-TYPE PAT)
-  (DO I 0 (1+ I) (= I 20)
+  (DO I 0 (1+ I) (= I CHATST-PACKET-LENGTH)
     (AS-1 (COND ((EQ PAT 'FLOATING-ONE) (LSH 1 I))
                 ((EQ PAT 'FLOATING-ZERO) (LOGXOR (LSH 1 I) -1))
@@ -96 +100 @@
 (DEFVAR CHATST-USE-RECEIVE-ALL T)               ;reasonable???
 
-(DEFUN CHATST ()
+(DEFUN CHATST (&OPTIONAL (LOOPBACK-COUNT 4) (CABLE-COUNT 4))
     "Standard test function for the chaos network interface.
 If it passes this test, sending and receiving packets from the network
@@ -105 +109 @@
 It does not send a properly formated packet with a header, but just
 a packet of raw bits."
+    (IF CHATST-USE-DEBUG (FORMAT T "~%Using debug interface"))
     (CHATST-RESET)
     (DOLIST (PAT '(FLOATING-ONE FLOATING-ZERO ADDRESS 52525 0 177777))
@@ -110 +115 @@
       (SET-PATTERN PAT)
       (LET ((CHATST-USE-RECEIVE-ALL T))
-        (DO I 0 (1+ I) (= I 4) (CHATST-PREP T) (CHATST-XMT) (CHATST-RCV)))
+        (DOTIMES (I LOOPBACK-COUNT)
+          (CHATST-PREP T) (CHATST-XMT) (CHATST-RCV)))
       (FORMAT T "~%Using the cable ~%")
       (LET ((CHATST-USE-RECEIVE-ALL NIL))
-        (DO I 0 (1+ I) (= I 4) (CHATST-PREP NIL) (CHATST-XMT) (CHATST-RCV T)))))
+        (DOTIMES (I CABLE-COUNT)
+          (CHATST-PREP NIL) (CHATST-XMT) (CHATST-RCV T)))))
 
 (DEFUN CHATST-ONCE (&OPTIONAL (LOOPBACK NIL) (CHATST-USE-RECEIVE-ALL LOOPBACK))
@@ -124 +131 @@
 (DEFUN CHATST-TR-LOOP (&OPTIONAL LOOPBACK &AUX (CHATST-USE-RECEIVE-ALL LOOPBACK))
   (CHATST-RESET)
-  (DO () ((KBD-TYI-NO-HANG)) (CHATST-PREP LOOPBACK) (CHATST-XMT) (CHATST-RCV T)))
+  (DO () ((FUNCALL TERMINAL-IO ':TYI-NO-HANG)) (CHATST-PREP LOOPBACK)
+      (CHATST-XMT) (CHATST-RCV T)))
 
 (DEFUN CHATST-XMT ()
-    "Send a packet consisting of 16 rotating 1's and my address."
-    (DO I 0 (1+ I) (= I 20)
-        (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
-    (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST (%UNIBUS-READ MY-NUMBER-REGISTER-TEST))
-    (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST ;improve chances of avoiding an abort
-                   (LOGIOR 10 (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST)))
-    (%UNIBUS-READ INITIATE-TRANSFER-REGISTER-TEST))
-
-(DEFUN CHATST-PACKET (&OPTIONAL (CABLE-DEST 440))       ;MC-11
+    "Send a packet consisting of 16 words of selected pattern and my address."
+    (DO I 0 (1+ I) (= I CHATST-PACKET-LENGTH)
+        (%u-write WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
+    (%u-write WRITE-BUFFER-REGISTER-TEST (%U-READ MY-NUMBER-REGISTER-TEST))
+    (%u-write CONTROL-STATUS-REGISTER-TEST      ;improve chances of avoiding an abort
+                   (LOGIOR 10 (%U-READ CONTROL-STATUS-REGISTER-TEST)))
+    (INITIATE-PACKET-TRANSMISSION))
+
+(DEFUN CHATST-PACKET (&OPTIONAL (CABLE-DEST 3040))      ;MC-11
     "Send a packet to some host (defaults to MC) which it will echo back."
-  (DO () ((bit-test 200 (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST)))) ;AWAIT TDONE
-  (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST 100000)  ;DATA
-  (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST 40) ;NBYTES
-  (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST 1440)       ;MC
-  (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST 0)
-  (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST chatst-address)     ;LISPM
+  (DO () ((bit-test 200 (%U-READ CONTROL-STATUS-REGISTER-TEST)))) ;AWAIT TDONE
+  (%u-write WRITE-BUFFER-REGISTER-TEST 100000)  ;DATA
+  (%u-write WRITE-BUFFER-REGISTER-TEST 40)      ;NBYTES
+  (%u-write WRITE-BUFFER-REGISTER-TEST 1440)    ;MC
+  (%u-write WRITE-BUFFER-REGISTER-TEST 0)
+  (%u-write WRITE-BUFFER-REGISTER-TEST chatst-address)  ;LISPM
   (DO I 0 (1+ I) (= I 3)                        ;SEND THE PATTERN AS IDX, PKT, ACK
-    (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
-  (DO I 0 (1+ I) (= I 20)                       ;SEND THE PATTERN AS 40 BYTES OF DATA
-    (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
-  (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST CABLE-DEST)
-  (%UNIBUS-READ INITIATE-TRANSFER-REGISTER-TEST))
-
-
-(DEFUN CHATST-LOOP (&OPTIONAL (CABLE-DEST 440) (LOOP-BACK-P NIL))       ;MC-11, NO LOOPBACK
+    (%u-write WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
+  (DO I 0 (1+ I) (= I CHATST-PACKET-LENGTH)     ;SEND THE PATTERN AS 40 BYTES OF DATA
+    (%u-write WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
+  (%u-write WRITE-BUFFER-REGISTER-TEST CABLE-DEST)
+  (INITIATE-PACKET-TRANSMISSION))
+
+
+(DEFUN CHATST-LOOP (&OPTIONAL (CABLE-DEST 3040) (LOOP-BACK-P NIL))      ;MC-11, NO LOOPBACK
     "Scope loop, ignore what is received (defaults to mc)"
-    (DO () ((KBD-TYI-NO-HANG))
+    (DO () ((FUNCALL TERMINAL-IO ':TYI-NO-HANG))
       (CHATST-PREP LOOP-BACK-P)
       (CHATST-PACKET CABLE-DEST)))
@@ -159 +167 @@
 ;;; Prepare the interface to receive.
 (DEFUN CHATST-PREP (LOOPBACK-P)
-  (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST
+  (%u-write CONTROL-STATUS-REGISTER-TEST
                  (+ (COND ((NOT LOOPBACK-P) 10) (T 12))
                     (COND ((NOT CHATST-USE-RECEIVE-ALL) 0) (T 4)))))
 
 (DEFUN CHATST-RESET ()
-    (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST 20000))
+    (%u-write CONTROL-STATUS-REGISTER-TEST 20000))
 
 (SETQ INBUF (MAKE-ARRAY NIL 'ART-16B 256.))
@@ -170 +178 @@
 
 ;;; Look for a received packet, and complain in various ways.
-(DEFUN CHATST-RCV ( &OPTIONAL BUSY-WAIT (CNT 16.) &AUX CSR TEM ME LOSE)
+(DEFUN CHATST-RCV ( &OPTIONAL BUSY-WAIT (CNT CHATST-PACKET-LENGTH) &AUX CSR TEM ME LOSE)
   (IF BUSY-WAIT
       (DO () ((LDB-TEST %%CHAOS-CSR-RECEIVE-DONE
-                        (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))))
+                        (%U-READ CONTROL-STATUS-REGISTER-TEST))))
       (PROCESS-SLEEP 10.))  ;Give it time to arrive
-  (SETQ CSR (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))
-  (SETQ ME (%UNIBUS-READ MY-NUMBER-REGISTER-TEST))
+  (SETQ CSR (%U-READ CONTROL-STATUS-REGISTER-TEST))
+  (SETQ ME (%U-READ MY-NUMBER-REGISTER-TEST))
   (IF (LDB-TEST %%CHAOS-CSR-TRANSMIT-ABORT CSR)
       (FORMAT t "~%Transmit aborted, then~%"))
@@ -182 +190 @@
          (SETQ LOSE T) (PRINT 'NO-RECEIVE))
         (T (AND (LDB-TEST %%CHAOS-CSR-CRC-ERROR CSR)
-                (PROGN (SETQ LOSE T)
+                (PROGN (SETQ LOSE 'CRC)
                        (PRINT '"CRC Error indicated (check the data)")))
-           (OR (= (%UNIBUS-READ BIT-COUNT-REGISTER-TEST) (1- (* 16. (+ 3 CNT))))
+           (OR (= (%U-READ BIT-COUNT-REGISTER-TEST) (1- (* 16. (+ 3 CNT))))
                (PROGN (SETQ LOSE T)
-                      (PRINT (LIST (%UNIBUS-READ BIT-COUNT-REGISTER-TEST) 'BAD-BIT-COUNT))))
+                      (PRINT (LIST (%U-READ BIT-COUNT-REGISTER-TEST) 'BAD-BIT-COUNT))))
            (DO I 0 (1+ I) (= I CNT)
-             (AS-1 (%UNIBUS-READ READ-BUFFER-REGISTER-TEST) INBUF I))
-           (OR (= (SETQ TEM (%UNIBUS-READ READ-BUFFER-REGISTER-TEST)) ME)
+             (AS-1 (%U-READ READ-BUFFER-REGISTER-TEST) INBUF I))
+           (IF ( (SETQ TEM (%U-READ READ-BUFFER-REGISTER-TEST)) ME)
                (PROGN (SETQ LOSE T)
                       (FORMAT T "~% DEST=~O SHOULD=~O" TEM ME)))
-           (OR (= (SETQ TEM (%UNIBUS-READ READ-BUFFER-REGISTER-TEST)) ME)
+           (IF ( (SETQ TEM (%U-READ READ-BUFFER-REGISTER-TEST)) ME)
                (PROGN (SETQ LOSE T)
                       (FORMAT T "~% SOURCE=~O SHOULD=~O" TEM ME)))
@@ -204 +212 @@
                     (DO I 0 (1+ I) (= I CNT)
                       (FORMAT T "~%~2O  ~6O ~6O" I (AR-1 CHATST-PATTERN I) (AR-1 INBUF I)))
-                    (RETURN NIL))))))
+                    (RETURN NIL))))
+           (%U-READ READ-BUFFER-REGISTER-TEST)  ;gobble the CRC word
+           (IF (AND (NOT (EQ LOSE 'CRC))        ;don't bother pointing this out, if already
+                    (LDB-TEST %%CHAOS-CSR-CRC-ERROR (%U-READ CONTROL-STATUS-REGISTER-TEST)))
+               (PROGN (FORMAT T "~%CRC error indicated after data readout~:[ even though data is correct~]."
+                              LOSE)
+                      (SETQ LOSE T)))
+           ))
   (OR LOSE (FORMAT T "~&WIN")))
 
@@ -215 +230 @@
   a random host sending garbage packets, etc."
   (CHATST-RESET)
-      (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST 14)        ;reset rcvr, RCV ALL
-  (DO () ((KBD-CHAR-AVAILABLE) (KBD-TYI-NO-HANG))
+  (%u-write CONTROL-STATUS-REGISTER-TEST 14)        ;reset rcvr, RCV ALL
+  (DO () ((FUNCALL TERMINAL-IO ':LISTEN) (FUNCALL TERMINAL-IO ':TYI-NO-HANG))
     (DO ((i 0 (1+ i)))
         ((> I 50.) (FORMAT T "."))
-      (COND ((bit-test 100000 (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))
+      (COND ((bit-test 100000 (%U-READ CONTROL-STATUS-REGISTER-TEST))
              (FORMAT T "~%---------------------~%")
-             (AND (LDB-TEST %%CHAOS-CSR-CRC-ERROR (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))
+             (AND (LDB-TEST %%CHAOS-CSR-CRC-ERROR (%U-READ CONTROL-STATUS-REGISTER-TEST))
                   (FORMAT T "CRC-Error "))
-             (SETQ BITS (1+ (%UNIBUS-READ BIT-COUNT-REGISTER-TEST))
+             (SETQ BITS (1+ (%U-READ BIT-COUNT-REGISTER-TEST))
                    CNT (// BITS 16.))
              (OR (ZEROP (\  BITS 16.))
@@ -229 +244 @@
              (COND ((AND SHORT-P (> CNT 8))
                     (DO I 0 (1+ I) (= I 5)
-                        (FORMAT T "~&~O   ~O" I (%UNIBUS-READ READ-BUFFER-REGISTER-TEST)))
+                        (FORMAT T "~&~O   ~O" I (%U-READ READ-BUFFER-REGISTER-TEST)))
                     (FORMAT T "~%     ...")
                     (DO I 0 (1+ I) (
- I (- CNT 8))(%UNIBUS-READ READ-BUFFER-REGISTER-TEST))
-                    (DO I (- CNT 3) (1+ I) (= I CNT)
-                        (FORMAT T "~%~O   ~O" I (%UNIBUS-READ READ-BUFFER-REGISTER-TEST))))
+ I (- CNT 8))(%U-READ READ-BUFFER-REGISTER-TEST))
+                    (LET ((D (%U-READ READ-BUFFER-REGISTER-TEST))
+                          (S (%U-READ READ-BUFFER-REGISTER-TEST))
+                          (CRC  (%U-READ READ-BUFFER-REGISTER-TEST)))
+                      (FORMAT T "~% dest ~O  ~A" D (SI:GET-HOST-FROM-ADDRESS D ':CHAOS))
+                      (FORMAT T "~% src  ~O  ~A" S (SI:GET-HOST-FROM-ADDRESS S ':CHAOS))
+                      (FORMAT T "~% CRC ~O" CRC)))
                    (T (DO I 0 (1+ I) (= I CNT)
-                          (FORMAT T "~&~O   ~O" I (%UNIBUS-READ READ-BUFFER-REGISTER-TEST)))))
-             (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST 14)        ;reset rcvr, RCV ALL
+                          (FORMAT T "~&~O   ~O" I (%U-READ READ-BUFFER-REGISTER-TEST)))))
+             (%u-write CONTROL-STATUS-REGISTER-TEST 14)        ;reset rcvr, RCV ALL
              (RETURN NIL)))))
   (CHATST-RESET))
@@ -248 +267 @@
    (AS-1 100000 CHATST-HEADER 0)                   ;OPCODE (DATA)
    (AS-1 0 CHATST-HEADER 1)                        ;LENGTH IN BYTES
-   (AS-1 chatst-address CHATST-HEADER 2)               ;DESTINATION (CAUSE FORWARDING)
+   (AS-1 chatst-address CHATST-HEADER 2)           ;DESTINATION (CAUSE FORWARDING)
    (AS-1 0 CHATST-HEADER 3)
-   (AS-1 chatst-address CHATST-HEADER 4)               ;SOURCE
+   (AS-1 chatst-address CHATST-HEADER 4)           ;SOURCE
    (DO I 0 (1+ I) (= I 3)                          ;SRC-IDX, PK#, ACK#
        (AS-1 (AR-1 CHATST-PATTERN I) CHATST-HEADER (+ I 5))))
 
-(CHATST-SET-HEADER)                                ;Setup an echo header
-
-(DEFUN CHATST-ECHO (&OPTIONAL (DEST 440)  (LEN 20))
+(DEFUN CHATST-ECHO (&OPTIONAL (DEST 3040)  (LEN CHATST-PACKET-LENGTH))
   (CHATST-RESET)
-  (SETQ LEN (MIN LEN 248.))         ;4096.-header
+  (CHATST-SET-HEADER)                           ;Setup an echo header
+  (SETQ LEN (MIN LEN 248.))                     ;4096.-header
   (AS-1 (* LEN 2) CHATST-HEADER 1)
   (DO ((pat1 0 (1+ pat1))
        (pat2 (random) (random)))
-      ((KBD-TYI-NO-HANG))
-    (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST 10)        ;reset rcvr
-      (do i 0 (+ i 2) (
+      ((FUNCALL TERMINAL-IO ':TYI-NO-HANG))
+    (%u-write CONTROL-STATUS-REGISTER-TEST 10)  ;reset rcvr
+    (do i 0 (+ i 2) (
  i len)
-          (as-1 pat1 chatst-pattern i)
-          (as-1 pat2 chatst-pattern (1+ i)))
-      (format t "~%Patterns ~O, ~O" pat1 pat2)
-      ;;Try this pattern 10. times
-      (do ((j 0 (1+ j))) ((= j 10.))
-          (DO ((i 0 (1+ i)))
-              ((bit-test 200 (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))) ;AWAIT TDONE
-              (COND ((> i 50.)
-                     (FORMAT T "~% TDONE timeout")
-                     (RETURN NIL))))
-          (DO I 0 (1+ I) (= I 8)    ;Fill in IDX, PKT, ACK with pattern 
-              (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-HEADER I)))
-          (DO I 0 (1+ I) (= I LEN)
-              (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
-          (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST 10)    ;reset rcvr
-          (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST DEST)
-          (%UNIBUS-READ INITIATE-TRANSFER-REGISTER-TEST)     ;start xmission
-          (DO ((i 0 (1+ i)))
-              ((> I 1000.) (FORMAT T "~% Rcv-done timeout"))
-              (COND ((BIT-TEST 100000 (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))
-                     (CHATST-CHECK-PK DEST LEN)
-                     (RETURN NIL)))) )))
+        (as-1 pat1 chatst-pattern i)
+        (as-1 pat2 chatst-pattern (1+ i)))
+    (format t "~%Patterns ~O, ~O" pat1 pat2)
+    ;;Try this pattern 10. times
+    (do ((j 0 (1+ j))) ((= j 10.))
+      (DO ((i 0 (1+ i)))
+          ((bit-test 200 (%U-READ CONTROL-STATUS-REGISTER-TEST)))       ;AWAIT TDONE
+        (COND ((> i 50.)
+               (FORMAT T "~% TDONE timeout")
+               (RETURN NIL))))
+      (DO I 0 (1+ I) (= I 8)                    ;Fill in IDX, PKT, ACK with pattern 
+          (%u-write WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-HEADER I)))
+      (DO I 0 (1+ I) (= I LEN)
+          (%u-write WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
+      (%u-write CONTROL-STATUS-REGISTER-TEST 10)        ;reset rcvr
+      (%u-write WRITE-BUFFER-REGISTER-TEST DEST)
+      (INITIATE-PACKET-TRANSMISSION)
+      (DO ((i 0 (1+ i)))
+          ((OR (bit-test 100 (%U-READ CONTROL-STATUS-REGISTER-TEST))
+               (> I 1000.))
+           (IF (bit-test 100 (%U-READ CONTROL-STATUS-REGISTER-TEST))
+               (FORMAT T "~%Transmit aborted.")
+               (FORMAT T "~% Rcv-done timeout")))
+        (COND ((BIT-TEST 100000 (%U-READ CONTROL-STATUS-REGISTER-TEST))
+               (CHATST-CHECK-PK DEST LEN T)
+               (RETURN NIL)))) )))
 
 ;;Scope trace - echo from some host
 
-(DEFUN CHATST-BUZZ (&OPTIONAL (DEST 440) (LEN 20))
+(DEFUN CHATST-BUZZ (&OPTIONAL (DEST 3040) (LEN CHATST-PACKET-LENGTH))
   (CHATST-RESET)
-  (SETQ LEN (MIN LEN 248.))         ;4096.-header
+  (SETQ LEN (MIN LEN 248.))                     ;4096.-header
   (AS-1 (* LEN 2) CHATST-HEADER 1)
-  (DO () ((KBD-TYI-NO-HANG)(CHATST-PRINT-STATUS DEST LEN))
-      (as-1 (1+ (ar-1 chatst-pattern 0)) chatst-pattern 0)
-      ;;Try this pattern 10. times
-      (do ((j 0 (1+ j))) ((= j 10.))
-          ;;Wait for Transmit side idle
-          (DO ((i 0 (1+ i)))
-              ((bit-test 200 (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST)))
-              (COND ((> i 50.)
-                     (FORMAT T "~% TDONE timeout")
-                     (RETURN NIL))))
-          ;;Fill in header, data with pattern
-          (DO I 0 (1+ I) (= I 8)
-              (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-HEADER I)))
-          (DO I 0 (1+ I) (= I LEN)
-              (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
-          (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST DEST)
-          ;;Now wait for echoed packet
-          (DO ((i 0 (1+ i)))
-              ((> I 50.))
-              (COND ((bit-test 100000 (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))
-                     (RETURN NIL))))
-          (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST (IF (= DEST 0) 12 10))
-          (%UNIBUS-READ INITIATE-TRANSFER-REGISTER-TEST))))
-
-(DEFUN CHATST-PRINT-STATUS ( &OPTIONAL (DEST 100) (LEN 16.))
+  (DO ()
+      ((FUNCALL TERMINAL-IO ':TYI-NO-HANG)
+       (CHATST-PRINT-STATUS DEST LEN))
+    (as-1 (1+ (ar-1 chatst-pattern 0)) chatst-pattern 0)
+    ;;Try this pattern 10. times
+    (do ((j 0 (1+ j))) ((= j 10.))
+      ;;Wait for Transmit side idle
+      (DO ((i 0 (1+ i)))
+          ((bit-test 200 (%U-READ CONTROL-STATUS-REGISTER-TEST)))
+        (COND ((> i 50.)
+               (FORMAT T "~% TDONE timeout")
+               (RETURN NIL))))
+      ;;Fill in header, data with pattern
+      (DO I 0 (1+ I) (= I 8)
+          (%u-write WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-HEADER I)))
+      (DO I 0 (1+ I) (= I LEN)
+          (%u-write WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
+      (%u-write WRITE-BUFFER-REGISTER-TEST DEST)
+      ;;Now wait for echoed packet
+      (DO ((i 0 (1+ i)))
+          ((> I 50.))
+        (COND ((bit-test 100000 (%U-READ CONTROL-STATUS-REGISTER-TEST))
+               (RETURN NIL))))
+      (%u-write CONTROL-STATUS-REGISTER-TEST (IF (= DEST 0) 12 10))
+      (INITIATE-PACKET-TRANSMISSION))))
+
+(DEFUN CHATST-PRINT-STATUS ( &OPTIONAL (DEST 100) (LEN CHATST-PACKET-LENGTH))
   (TERPRI)
   (PROCESS-SLEEP 30.)  ;Give it time to arrive
@@ -327 +351 @@
 
 
-(DEFUN CHATST-CHECK-PK (&OPTIONAL (DEST-HOST 100) (CNT 16.) &AUX DEST CSR TEM ME BITS)
-  (SETQ CSR (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST)
-        ME (%UNIBUS-READ MY-NUMBER-REGISTER-TEST)
-        BITS (1- (* 16. (+ 11. CNT)))
-        DEST DEST-HOST)
+(DEFUN CHATST-CHECK-PK (&OPTIONAL (DEST-HOST 100) (CNT CHATST-PACKET-LENGTH) IGNORE-DEST-0
+                        &AUX (CSR (%U-READ CONTROL-STATUS-REGISTER-TEST))
+                             ME BITS BITS1 DEST SRC1 DEST1)
+  (SETQ ME (%U-READ MY-NUMBER-REGISTER-TEST)
+        BITS (1- (* 16. (+ 11. CNT)))
+        BITS1 (%U-READ BIT-COUNT-REGISTER-TEST)
+        DEST DEST-HOST
+        SRC1 (%U-READ READ-BUFFER-REGISTER-TEST)
+        DEST1 (%U-READ READ-BUFFER-REGISTER-TEST))
   (AND (LDB-TEST %%CHAOS-CSR-CRC-ERROR CSR)
        (PRINT 'CRC-ERROR))
-  (OR (= (SETQ TEM (%UNIBUS-READ BIT-COUNT-REGISTER-TEST)) BITS)
-      (FORMAT T "~%Bad bit count, is ~O, should be ~O" TEM BITS))
-  (DO I 0 (1+ I) (= I (+ 8 CNT))
-      (AS-1 (%UNIBUS-READ READ-BUFFER-REGISTER-TEST) INBUF I))
-  (OR (= (SETQ TEM (%UNIBUS-READ READ-BUFFER-REGISTER-TEST)) ME)
-         (FORMAT T "~% DEST=~O, should be ~O"  TEM ME))
-  (OR (= (SETQ TEM (%UNIBUS-READ READ-BUFFER-REGISTER-TEST)) DEST)
-         (FORMAT T "~% SOURCE=~O, should be ~O"  TEM DEST))
-  (AS-1 (LOGAND (AR-1 INBUF 1) 7777) INBUF 1)           ;FLUSH FORWARDING COUNT
-  (DO I 0 (1+ I) (= I 8)
-      (COND (( (AR-1 CHATST-HEADER I) (AR-1 INBUF I))
-             (TERPRI) (PRINC "HEADER  SENT    RCVD")
-             (DO I 0 (1+ I) (= I 8)
-                 (FORMAT T "~%~2O  ~6O ~6O" I (AR-1 CHATST-HEADER I) (AR-1 INBUF I)))
-             (RETURN NIL))))
-  (DO ((I 0 (1+ I)) (J 8 (1+ J))) ((= I CNT))
-      (COND (( (AR-1 CHATST-PATTERN I) (AR-1 INBUF J))
-             (TERPRI) (PRINC "LOC    SENT    RCVD")
-             (DO ((I 0 (1+ I))(J 8 (1+ J))) ((= I CNT))
-                 (FORMAT T "~%~2O  ~6O ~6O" I (AR-1 CHATST-PATTERN I) (AR-1 INBUF J)))
-             (RETURN NIL))))
-  (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST 10)    ;reset rcvr
-)
-
-(DEFUN CHATST-ECHO-ONCE (&OPTIONAL (DEST 500) (LEN 20))
-       (DO ()((bit-test 200 (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))))
+  (DO I 0 (1+ I) (= I (+ 8 CNT))                ;skip first words of header
+      (AS-1 (%U-READ READ-BUFFER-REGISTER-TEST) INBUF I))
+  (COND ((AND IGNORE-DEST-0 (= DEST1 0)))
+        (T (OR (= BITS1 BITS)
+               (FORMAT T "~%Bad bit count, is ~O, should be ~O" BITS1 BITS))
+           (OR (= DEST1 ME) (FORMAT T "~% DEST=~O, should be ~O"  DEST1 ME))
+           (OR (= SRC1 DEST) (FORMAT T "~% SOURCE=~O, should be ~O"  SRC1 DEST))
+           (AS-1 (LOGAND (AR-1 INBUF 1) 7777) INBUF 1)  ;FLUSH FORWARDING COUNT
+           (DO I 0 (1+ I) (= I 8)
+               (COND (( (AR-1 CHATST-HEADER I) (AR-1 INBUF I))
+                      (TERPRI) (PRINC "HEADER  SENT    RCVD")
+                      (DO I 0 (1+ I) (= I 8)
+                          (FORMAT T "~%~2O  ~6O ~6O" I (AR-1 CHATST-HEADER I) (AR-1 INBUF I)))
+                      (RETURN NIL))))
+           (DO ((I 0 (1+ I)) (J 8 (1+ J))) ((= I CNT))
+             (COND (( (AR-1 CHATST-PATTERN I) (AR-1 INBUF J))
+                    (TERPRI) (PRINC "LOC    SENT    RCVD")
+                    (DO ((I 0 (1+ I))(J 8 (1+ J))) ((= I CNT))
+                      (FORMAT T "~%~2O  ~6O ~6O" I (AR-1 CHATST-PATTERN I) (AR-1 INBUF J)))
+                    (RETURN NIL))))))
+  (%u-write CONTROL-STATUS-REGISTER-TEST 10)    ;reset rcvr
+           )
+
+(DEFUN CHATST-ECHO-ONCE (&OPTIONAL (DEST 500) (LEN CHATST-PACKET-LENGTH))
+       (DO ()((bit-test 200 (%U-READ CONTROL-STATUS-REGISTER-TEST))))
        (DO I 0 (1+ I) (= I LEN)                 ;SEND THE PATTERN AS 40 BYTES OF DATA
-           (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
-      (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST DEST)
-      (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST 10)    ;reset rcvr
-      (%UNIBUS-READ INITIATE-TRANSFER-REGISTER-TEST)
+           (%u-write WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
+      (%u-write WRITE-BUFFER-REGISTER-TEST DEST)
+      (%u-write CONTROL-STATUS-REGISTER-TEST 10)    ;reset rcvr
+      (INITIATE-PACKET-TRANSMISSION)
       (DO ((i 0 (1+ i)))
-          ((or (bit-test 200 (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))
+          ((or (bit-test 200 (%U-READ CONTROL-STATUS-REGISTER-TEST))
                (> i 50.)))) ;AWAIT TDONE
-      (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST 14)        ;RCV ALL
+      (%u-write CONTROL-STATUS-REGISTER-TEST 14)        ;RCV ALL
       (CHATST-PRINT-STATUS DEST LEN))
 
@@ -374 +401 @@
     "Describes the bits currently on in the control status register for the
 board being tested."
-    (SETQ CSR (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))
+    (SETQ CSR (%U-READ CONTROL-STATUS-REGISTER-TEST))
     (FORMAT T "~2%CSR = ~O~%" CSR)
     (AND (LDB-TEST %%CHAOS-CSR-TIMER-INTERRUPT-ENABLE CSR)
@@ -400 +427 @@
     (AND (LDB-TEST %%CHAOS-CSR-RECEIVE-DONE CSR)
          (FORMAT T "Receive done.~%"))
-    (FORMAT T "Bit count: ~O~%" (%UNIBUS-READ BIT-COUNT-REGISTER-TEST))
+    (FORMAT T "Bit count: ~O~%" (%U-READ BIT-COUNT-REGISTER-TEST))
     NIL)
 
 (DEFUN CHATST-SOAK (&AUX (M-ONES 0) (OTHERS 0))
-  (%unibus-write control-status-register-test 14)
-  (DO () ((KBD-TYI-NO-HANG) (FORMAT T "~%-1 length packets ~O, others ~O" m-ones others))
-    (COND ((bit-test 100000 (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))
+  (%u-write control-status-register-test 14)
+  (DO () ((FUNCALL TERMINAL-IO ':TYI-NO-HANG) (FORMAT T "~%-1 length packets ~O, others ~O" m-ones others))
+    (COND ((bit-test 100000 (%U-READ CONTROL-STATUS-REGISTER-TEST))
 ;          (DO ((I 0 (1+ I))) ((> I 10.))
-;            (FORMAT T "~%~O" (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST)))
-           (let ((tem (%unibus-read bit-count-register-test)))
+;            (FORMAT T "~%~O" (%U-READ CONTROL-STATUS-REGISTER-TEST)))
+           (let ((tem (%u-read bit-count-register-test)))
              (if (= tem 7777)                   ;Null packet "received"
                  (setq m-ones (1+ m-ones))
                  (setq others (1+ others))))
-               (%unibus-write control-status-register-test 14)))))
+               (%u-write control-status-register-test 14)))))
 
 
@@ -433 +460 @@
         (SI:MAKE-24-BIT-UNSIGNED (+ 77400000 (LSH ADDR -1))))  ; SET THE A MEMORY LOCATION
   (INITIALIZE-NCP-SYSTEM)
-  (%UNIBUS-WRITE OLD-CSR 20010)                 ;avoid interrupt hang screw
-  (%UNIBUS-WRITE CONTROL-STATUS-REGISTER 20010)
+  (%u-write OLD-CSR 20010)                      ;avoid interrupt hang screw
+  (%u-write CONTROL-STATUS-REGISTER 20010)
   (FORMAT NIL "NCP now using ~6O as the network interface base address." ADDR))
 
@@ -440 +467 @@
 (DEFUN TIMER-LOOP (&OPTIONAL (COUNT 511.) (SLEEP-TIME 1))
   "Scope loop for looking at the interval timer."
-  (DO NIL ((KBD-TYI-NO-HANG))
-    (%UNIBUS-WRITE INTERVAL-TIMER-REGISTER-TEST COUNT)
+  (DO NIL ((FUNCALL TERMINAL-IO ':TYI-NO-HANG))
+    (%u-write INTERVAL-TIMER-REGISTER-TEST COUNT)
     (PROCESS-SLEEP SLEEP-TIME)))
+
+(DEFUN %U-READ (ADR)
+  (IF CHATST-USE-DEBUG
+      (CADR:DBG-READ ADR)
+      (%UNIBUS-READ ADR)))
+
+(DEFUN %U-WRITE (ADR DATA)
+  (IF CHATST-USE-DEBUG
+      (CADR:DBG-WRITE ADR DATA)
+      (%UNIBUS-WRITE ADR DATA)))
+
+(SET-BASE-ADDRESS)

trunk/lisp/lmio1/ctest.lisp

@@ -3 +3 @@
 ;work rotation xfrm
 
-(DEFCONST CTEST-BOARD-TYPE 'LG684)  ;OR MPG216
+(DEFCONST CTEST-BOARD-TYPE 'MPG216)  ;OR LG684
 
 ;Continuity Tester Interface
@@ -689 +689 @@
 ;RETEST BAD RUNS.  NOTE THEY ARE IN TEXT FORM
 (DEFUN CTEST-RETEST-BAD-RUNS (&OPTIONAL (BAD-RUNS CTEST-BAD-RUNS))
+  (SETQ CTEST-OLD-BAD-RUNS CTEST-BAD-RUNS)
+  (SETQ CTEST-BAD-RUNS NIL)
   (CTEST-TRY-TESTING 0 (MAPCAR (FUNCTION CTEST-UNCONVERT-RUN)
                                (MAPCAR (FUNCTION CAR) BAD-RUNS))))
@@ -748 +750 @@
         (SETQ LOC-LIST (CADR RUN) SEG-NO 0)
    L    (COND ((NULL (CDR LOC-LIST))
-               (RETURN (LIST (CTEST-CONVERT-RUN RUN) ANS)))
-              ((TEST-WIRE (LIST (CAR RUN) (SETQ SEG-NO (1+ SEG-NO)))
+               (RETURN (LIST (CTEST-CONVERT-RUN RUN) ANS))))
+        (SETQ SEG-NO (1+ SEG-NO))
+        (COND ((TEST-WIRE (CAR RUN)
                           (CAR LOC-LIST)
                           (CADR LOC-LIST))

trunk/lisp/lmio1/eftp.lisp

@@ -1 @@
-;-*- Mode:LISP; Package:CHAOS -*-
+;-*- Mode:LISP; Package:CHAOS; Base:8 -*-
 
 ;This file implements EFTP on the Lisp machine,
-;with the cooperation of CHSNCP.
-
-;Note, some of these 22.'s are 10.+12., the sum of the Muppet header size
-;and the PUP header size.  Other 22.'s are 2.*11., the number of non-data bytes
-;in a PUP.
-
-(DEFVAR PUP-INT-PKT NIL)        ;NIL or INT-PKT containing a PUP just received
-(DEFVAR PUP-INT-PKT-PORT NIL)   ;NIL or port expecting a packet
-(DEFVAR NEXT-LOCAL-PORT 1000)   ;Used to generate unique port numbers
-(DEFVAR MAX-PUP-DATA-BYTES 458.)        ;480-22
-
-;Kludge since the CHSNCP doesn't currently pay any attention to routing information
-;broadcast on the net.
-(ASET 426 ROUTING-TABLE 2)
-
-;Structure of a PUP in a Muppet in an INT-PKT
-(DEFSTRUCT (PUP :ARRAY (:CONSTRUCTOR NIL))
-  ((MUPPET-VERSION 0010) (MUPPET-PROTOCOL 1010))
-  ((MUPPET-FORWARD-COUNT 0010) (MUPPET-MISC-BYTE 1010))
-  (MUPPET-DEST-HOST)
-  (MUPPET-DEST-PORT)
-  (MUPPET-SOURCE-HOST)
-  (MUPPET-SOURCE-PORT)
-  (MUPPET-PACKET-NUMBER)
-  (MUPPET-DATA-LENGTH)
-  (MUPPET-FRAGMENT-POSITION)
-  (MUPPET-FRAGMENT-LENGTH)
-  (MUPPET-MISC-WORD)
-  (MUPPET-CHECKSUM)
+;with the cooperation of CHSNCP, using the Chaosnet foreign-protocol protocol.
+
+(DEFCONST PUP-NON-DATA-BYTES 22.)       ;10. words of header and a checksum
+(DEFCONST MAX-PUP-DATA-BYTES (- MAX-DATA-BYTES-PER-PKT PUP-NON-DATA-BYTES))
+(DEFCONST PUP-PROTOCOL-ID 100001)
+
+;Structure of a PUP in a Chaosnet packet
+;Cannot use (:INCLUDE PKT) because PKT defstruct has some garbage at the end
+(DEFSTRUCT (PUP :ARRAY (:CONSTRUCTOR NIL)
+                (:INITIAL-OFFSET #.FIRST-DATA-WORD-IN-PKT) (:SIZE-SYMBOL PUP-FIRST-DATA-WORD))
   (PUP-OVERALL-LENGTH)
   ((PUP-TYPE 0010) (PUP-TRANSPORT 1010))
@@ -40 +21 @@
   (PUP-SOURCE-HOST)
   (PUP-SOURCE-PORT-HIGH)
-  (PUP-SOURCE-PORT-LOW)
-  ;Word 22. is the first data word.  Pup checksum after the data
-  )
+  (PUP-SOURCE-PORT-LOW))        ;Data follow, then checksum
 
-;Get a PUP buffer which can be filled in then transmitted
-(DEFUN GET-PUP (DEST-HOST DEST-PORT SOURCE-PORT
-                PUP-TYPE PUP-ID
-                &AUX (INT-PKT (ALLOCATE-INT-PKT)))
-  (FILLARRAY INT-PKT '(0))
-  (SETF (MUPPET-VERSION INT-PKT) 1)
-  (SETF (MUPPET-PROTOCOL INT-PKT) 3)
-  (SETF (MUPPET-DEST-HOST INT-PKT) DEST-HOST)
-  (SETF (MUPPET-DEST-PORT INT-PKT) (LDB 0020 DEST-PORT))
-  (SETF (MUPPET-SOURCE-HOST INT-PKT) MY-ADDRESS)
-  (SETF (MUPPET-SOURCE-PORT INT-PKT) SOURCE-PORT)
-  (SETF (MUPPET-PACKET-NUMBER INT-PKT) PUP-ID)
-  (SETF (MUPPET-CHECKSUM INT-PKT) -1)           ;None
-  (SETF (PUP-TYPE INT-PKT) PUP-TYPE)
-  (SETF (PUP-ID-HIGH INT-PKT) (LDB 2020 PUP-ID))
-  (SETF (PUP-ID-LOW INT-PKT) (LDB 0020 PUP-ID))
-  (SETF (PUP-DEST-HOST INT-PKT) DEST-HOST)
-  (SETF (PUP-DEST-PORT-HIGH INT-PKT) (LDB 2020 DEST-PORT))
-  (SETF (PUP-DEST-PORT-LOW INT-PKT) (LDB 0020 DEST-PORT))
-  (SETF (PUP-SOURCE-HOST INT-PKT) MY-ADDRESS)
-  (SETF (PUP-SOURCE-PORT-LOW INT-PKT) SOURCE-PORT)
-  INT-PKT)
+;Get a PUP buffer which can be filled in then transmitted via TRANSMIT-PUP
+(DEFUN GET-PUP (CONN PUP-TYPE PUP-ID
+                &AUX (PKT (GET-PKT)))
+  (COPY-ARRAY-PORTION PKT 0 0 PKT 0 (ARRAY-LENGTH PKT)) ;Clear to zero
+  (SETF (PUP-TYPE PKT) PUP-TYPE)
+  (SETF (PUP-ID-HIGH PKT) (LDB 2020 PUP-ID))
+  (SETF (PUP-ID-LOW PKT) (LDB 0020 PUP-ID))
+  (SETF (PUP-DEST-HOST PKT) (FOREIGN-ADDRESS CONN))
+  (SETF (PUP-DEST-PORT-HIGH PKT) (LDB 2020 (FOREIGN-INDEX-NUM CONN)))
+  (SETF (PUP-DEST-PORT-LOW PKT) (LDB 0020 (FOREIGN-INDEX-NUM CONN)))
+  (SETF (PUP-SOURCE-HOST PKT) MY-ADDRESS)
+  (SETF (PUP-SOURCE-PORT-LOW PKT) (LOCAL-INDEX-NUM CONN))
+  PKT)
+
+;The header of a PUP is words and the data portion is bytes.
+;The bytes are already in Lisp machine order, but the header needs to be fixed.
+(DEFUN SWAB-PUP (PUP)
+  (LOOP FOR I FROM FIRST-DATA-WORD-IN-PKT BELOW PUP-FIRST-DATA-WORD
+        AS WD = (AREF PUP I)
+        DO (ASET (DPB WD 1010 (LDB 1010 WD)) PUP I))
+  PUP)
+
+;Accessor for binary data in a PUP
+(DEFUN PUP-WORD (PUP I)
+  (LET ((WD (AREF PUP (+ PUP-FIRST-DATA-WORD I))))
+    (DPB WD 1010 (LDB 1010 WD))))
+
+(DEFPROP PUP-WORD ((PUP-WORD PUP I) . (PUP-STORE-WORD PUP I SI:VAL)) SETF)
+(DEFUN PUP-STORE-WORD (PUP I WD)
+  (ASET (DPB WD 1010 (LDB 1010 WD)) PUP (+ PUP-FIRST-DATA-WORD I)))
 
 ;Compute the checksum of a PUP
-(DEFUN CHECKSUM-PUP (INT-PKT)
-  (DO ((I 12. (1+ I))
+(DEFUN CHECKSUM-PUP (PKT)
+  (DO ((I -10. (1+ I))
        (CK 0)
-       (N (LSH (1- (PUP-OVERALL-LENGTH INT-PKT)) -1) (1- N)))
+       (N (LSH (1- (PKT-NBYTES PKT)) -1) (1- N)))
       ((ZEROP N)
        (AND (= CK 177777) (SETQ CK 0))          ;Gronk minus zero
        (RETURN CK I))                           ;Return checksum and index in PUP of cksm
-    (SETQ CK (+ CK (AREF INT-PKT I)))           ;1's complement add
+    (SETQ CK (+ CK (PUP-WORD PKT I)))           ;1's complement add
     (AND (BIT-TEST 200000 CK) (SETQ CK (LDB 0020 (1+ CK))))
     (SETQ CK (DPB CK 0117 (LDB 1701 CK)))))     ;16-bit left rotate
 
 ;Fire off a PUP previously gotten from GET-PUP
-(DEFUN TRANSMIT-PUP (INT-PKT N-BYTES)
-  (SETF (MUPPET-DATA-LENGTH INT-PKT) (+ 22. N-BYTES))
-  (SETF (PUP-OVERALL-LENGTH INT-PKT) (+ 22. N-BYTES))
-  (MULTIPLE-VALUE-BIND (CKSM CKSMX) (CHECKSUM-PUP INT-PKT)
-    (ASET CKSM INT-PKT CKSMX)
-    (ASET (AREF ROUTING-TABLE (LDB 1010 (MUPPET-DEST-HOST INT-PKT))) INT-PKT (1+ CKSMX))
-    (SETF (INT-PKT-WORD-COUNT INT-PKT) (+ CKSMX 2))
-    (OR (= (%AREA-NUMBER INT-PKT) CHAOS-BUFFER-AREA)
-        (FERROR NIL "Attempt to transmit non-interrupt packet ~A" INT-PKT))
-    (WITHOUT-INTERRUPTS                         ;Ah, modularity, wonderful modularity.
-     (PROG (OLD-TRANSMIT-LIST)
-         (SETQ PKTS-TRANSMITTED (1+ PKTS-TRANSMITTED))
-      LOOP
-         (SETQ OLD-TRANSMIT-LIST (INT-TRANSMIT-LIST))
-         (SETF (INT-PKT-THREAD INT-PKT) OLD-TRANSMIT-LIST)
-         (OR (%STORE-CONDITIONAL INT-TRANSMIT-LIST-POINTER OLD-TRANSMIT-LIST INT-PKT)
-             (GO LOOP))
-         (%CHAOS-WAKEUP)))))
+(DEFUN TRANSMIT-PUP (CONN PKT N-BYTES)
+  (SETF (PKT-NBYTES PKT) (+ PUP-NON-DATA-BYTES N-BYTES))
+  (SETF (PUP-OVERALL-LENGTH PKT) (+ PUP-NON-DATA-BYTES N-BYTES))
+  (SETF (PKT-ACK-NUM PKT) PUP-PROTOCOL-ID)
+  (SWAB-PUP PKT)
+  (MULTIPLE-VALUE-BIND (CKSM CKSMX) (CHECKSUM-PUP PKT)
+    (SETF (PUP-WORD PKT CKSMX) CKSM))
+  (SEND-UNC-PKT CONN PKT)
+  (SWAB-PUP PKT))       ;Put back in case caller retransmits it
 
 ;Internal routine to get back a PUP on a specified port, with timeout
-;Returns INT-PKT or NIL.
-(DEFUN RECEIVE-PUP (PORT &OPTIONAL (TIMEOUT 60.)
-                    &AUX (START-TIME (TIME)) PUP)
-  (UNWIND-PROTECT
-    (DO () ((OR PUP-INT-PKT (> (TIME-DIFFERENCE (TIME) START-TIME) TIMEOUT))
-            (WITHOUT-INTERRUPTS
-              (SETQ PUP PUP-INT-PKT
-                    PUP-INT-PKT NIL))
-            (AND PUP
-                 (MULTIPLE-VALUE-BIND (CKSM CKSMX) (CHECKSUM-PUP PUP)
-                   (OR (= (AREF PUP CKSMX) 177777)
-                       (= (AREF PUP CKSMX) CKSM)
-                       (PROGN (FREE-INT-PKT PUP)
-                              (SETQ PUP NIL)))))
-            PUP)
-      (SETQ PUP-INT-PKT-PORT PORT)
-      (PROCESS-WAIT "PUP in" #'(LAMBDA (START-TIME TIMEOUT)
-                                 (OR PUP-INT-PKT
-                                     (> (TIME-DIFFERENCE (TIME) START-TIME) TIMEOUT)))
-                             START-TIME TIMEOUT))
-    (SETQ PUP-INT-PKT-PORT NIL)))
+;Returns PKT or NIL.
+(DEFUN RECEIVE-PUP (CONN &OPTIONAL (TIMEOUT 60.))
+  (LOOP WITH START-TIME = (TIME)
+        AS PUP = (GET-NEXT-PKT CONN T)
+        WHEN PUP
+          IF (AND (= (PKT-OPCODE PUP) UNC-OP)
+                  (= (PKT-ACK-NUM PUP) PUP-PROTOCOL-ID)
+                  (MULTIPLE-VALUE-BIND (CKSM CKSMX) (CHECKSUM-PUP PUP)
+                    (LET ((CK (PUP-WORD PUP CKSMX)))
+                      (OR (= CK 177777) (= CK CKSM)))))
+          RETURN (SWAB-PUP PUP)
+          ELSE DO (RETURN-PKT PUP)
+        DO (PROCESS-WAIT "PUP in"
+                         #'(LAMBDA (CONN START-TIME TIMEOUT)
+                             (OR (READ-PKTS CONN)
+                                 (> (TIME-DIFFERENCE (TIME) START-TIME) TIMEOUT)))
+                         CONN START-TIME TIMEOUT)
+        UNTIL (> (TIME-DIFFERENCE (TIME) START-TIME) TIMEOUT)))
 
 ;Cons a string containing characters taken from a PUP
-(DEFUN PUP-STRING (PUP &OPTIONAL (FROM 0) (TO (- (PUP-OVERALL-LENGTH PUP) 22.)))
-  (LET ((STR (MAKE-ARRAY NIL 'ART-STRING (MAX (- TO FROM) 0))))
-    (DO ((I FROM (1+ I))
-         (J 0 (1+ J))
-         (WD))
-        ((
- I TO))
-      (SETQ WD (AREF PUP (+ (// I 2) 22.)))
-      (ASET (LDB (IF (ODDP I) 0010 1010) WD) STR J))
-    STR))
-
-(DEFUN GET-PORT-NUMBER ()
-  (WITHOUT-INTERRUPTS (PROG1 NEXT-LOCAL-PORT
-                             (SETQ NEXT-LOCAL-PORT (1+ NEXT-LOCAL-PORT))
-                             (AND (> NEXT-LOCAL-PORT 177777)
-                                  (SETQ NEXT-LOCAL-PORT 1000)))))
-
-;Complain about random PUP we may have received, and free the INT-PKT
+(DEFUN PUP-STRING (PUP &OPTIONAL (FROM 0) (TO (- (PUP-OVERALL-LENGTH PUP)
+                                                 PUP-NON-DATA-BYTES)))
+  (SUBSTRING (PKT-STRING PUP) (+ 20. FROM) (+ 20. TO))) ;20. is bytes in pup header
+
+;Complain about random PUP we may have received, and free the PKT
 ;Put a trace breakpoint on this if you are trying to figure out what's going on.
 (DEFUN RECEIVED-RANDOM-PUP (PUP)
@@ -150 +112 @@
           (DPB (PUP-SOURCE-PORT-HIGH PUP) 2020 (PUP-SOURCE-PORT-LOW PUP))
           (= (PUP-TYPE PUP) 4)          ;Error
-          (AREF PUP 32.)                ;Standard code
-          (AREF PUP 33.)                ;Misc argument to it
+          (PUP-WORD PUP 10.)            ;Standard code
+          (PUP-WORD PUP 11.)            ;Misc argument to it
           (PUP-STRING PUP 24.))         ;Human readable text
-  (FREE-INT-PKT PUP)
-  (KBD-CHAR-AVAILABLE))                 ;Chance to hit call
+  (RETURN-PKT PUP))
 
 ;EFTP-write stream.
 (DEFVAR EFTP-NEXT-PUP-ID)
-(DEFVAR EFTP-FOREIGN-HOST)
-(DEFVAR EFTP-FOREIGN-PORT)
-(DEFVAR EFTP-LOCAL-PORT)
+(DEFVAR EFTP-CONN)
 (DEFVAR EFTP-BINARY-P)
 (DEFVAR EFTP-BUFFER)
 
-(DEFUN MAKE-EFTP-WRITE-STREAM (EFTP-FOREIGN-HOST
-                               &OPTIONAL (EFTP-BINARY-P NIL) (EFTP-FOREIGN-PORT 20))
+(DEFUN MAKE-EFTP-WRITE-STREAM (FOREIGN-HOST
+                               &OPTIONAL (EFTP-BINARY-P NIL) (FOREIGN-PORT 20))
   (LET ((EFTP-NEXT-PUP-ID 0)
-        (EFTP-LOCAL-PORT (GET-PORT-NUMBER))
-        (EFTP-BUFFER (MAKE-ARRAY NIL 'ART-8B MAX-PUP-DATA-BYTES NIL '(0))))
-    (CLOSURE '(EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-NEXT-PUP-ID
-               EFTP-LOCAL-PORT EFTP-BINARY-P EFTP-BUFFER)
+        (EFTP-BUFFER (MAKE-ARRAY MAX-PUP-DATA-BYTES ':TYPE 'ART-8B ':LEADER-LIST '(0)))
+        (EFTP-CONN (OPEN-FOREIGN-CONNECTION FOREIGN-HOST FOREIGN-PORT)))
+    (CLOSURE '(EFTP-NEXT-PUP-ID EFTP-CONN EFTP-BINARY-P EFTP-BUFFER)
              'EFTP-WRITE-STREAM)))
 
@@ -206 +164 @@
                  (PUP))
                 (NIL)
-              (SETQ PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-LOCAL-PORT 32 ID))
-              (TRANSMIT-PUP PUP 0)
-              (COND ((NULL (SETQ PUP (RECEIVE-PUP EFTP-LOCAL-PORT)))
+              (SETQ PUP (GET-PUP EFTP-CONN 32 ID))
+              (TRANSMIT-PUP EFTP-CONN PUP 0)
+              (COND ((NULL (SETQ PUP (RECEIVE-PUP EFTP-CONN)))
                      (AND (ZEROP (\ N-RETRANSMISSIONS 10.))
                           (FORMAT ERROR-OUTPUT
-                                  "~&[Host not responding to EFTP_End, still trying...]~%"))
-                     (KBD-CHAR-AVAILABLE))
+                                  "~&[Host not responding to EFTP_End, still trying...]~%")))
                     ((= (PUP-TYPE PUP) 33)
                      (FORMAT ERROR-OUTPUT "~&EFTP Abort in EFTP_End, code ~D, ~A~%"
-                             (AREF PUP 22.) (PUP-STRING PUP 2))
-                     (FREE-INT-PKT PUP)
+                             (PUP-WORD PUP 0) (PUP-STRING PUP 2))
+                     (RETURN-PKT PUP)
                      (BREAK EFTP-ABORT))
                     ((NOT (= (PUP-TYPE PUP) 31))
                      (RECEIVED-RANDOM-PUP PUP))
                     ((NOT (= (DPB (PUP-ID-HIGH PUP) 2020 (PUP-ID-LOW PUP)) ID))
-                     (FREE-INT-PKT PUP))                ;Ignore random old acks
-                    (T (FREE-INT-PKT PUP)
+                     (RETURN-PKT PUP))          ;Ignore random old acks
+                    (T (RETURN-PKT PUP)         ;Good ack
                        (RETURN NIL))))
-            (TRANSMIT-PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT
-                                   EFTP-LOCAL-PORT 32 EFTP-NEXT-PUP-ID) 0))
+            (TRANSMIT-PUP EFTP-CONN (GET-PUP EFTP-CONN 32 EFTP-NEXT-PUP-ID) 0)
+            (REMOVE-CONN EFTP-CONN))
     (OTHERWISE (STREAM-DEFAULT-HANDLER #'EFTP-WRITE-STREAM OP ARG1 ARGS))))
 
@@ -234 +191 @@
             (PUP))
            (NIL)
-         (SETQ PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-LOCAL-PORT 30 ID))
+         (SETQ PUP (GET-PUP EFTP-CONN 30 ID))
          (DOTIMES (I (// (1+ (ARRAY-ACTIVE-LENGTH EFTP-BUFFER)) 2))
-           (ASET (+ (LSH (AREF EFTP-BUFFER (* I 2)) 8) (AREF EFTP-BUFFER (1+ (* I 2))))
-                 PUP (+ I 22.)))
-         (TRANSMIT-PUP PUP (ARRAY-ACTIVE-LENGTH EFTP-BUFFER))
-         (COND ((NULL (SETQ PUP (RECEIVE-PUP EFTP-LOCAL-PORT)))
+           (ASET (DPB (AREF EFTP-BUFFER (1+ (* I 2))) 1010 (AREF EFTP-BUFFER (* I 2)))
+                 PUP (+ I PUP-FIRST-DATA-WORD)))
+         (TRANSMIT-PUP EFTP-CONN PUP (ARRAY-ACTIVE-LENGTH EFTP-BUFFER))
+         (COND ((NULL (SETQ PUP (RECEIVE-PUP EFTP-CONN)))
                 (AND (ZEROP (\ N-RETRANSMISSIONS 10.))
-                     (FORMAT ERROR-OUTPUT "~&[Host not responding, still trying...]~%"))
-                (KBD-CHAR-AVAILABLE))
+                     (FORMAT ERROR-OUTPUT "~&[Host not responding, still trying...]~%")))
                ((= (PUP-TYPE PUP) 33)
                 (FORMAT ERROR-OUTPUT "~&EFTP Abort code ~D, ~A~%"
-                        (AREF PUP 22.) (PUP-STRING PUP 2))
-                (FREE-INT-PKT PUP)
+                        (PUP-WORD PUP 0) (PUP-STRING PUP 2))
+                (RETURN-PKT PUP)
                 (BREAK EFTP-ABORT))
                ((NOT (= (PUP-TYPE PUP) 31))
                 (RECEIVED-RANDOM-PUP PUP))
                ((NOT (= (DPB (PUP-ID-HIGH PUP) 2020 (PUP-ID-LOW PUP)) ID))
-                (FREE-INT-PKT PUP))             ;Ignore random old acks
-               (T (FREE-INT-PKT PUP)
+                (RETURN-PKT PUP))               ;Ignore random old acks
+               (T (RETURN-PKT PUP)              ;Good ack
                   (RETURN NIL)))))              ;Bingo!
   (STORE-ARRAY-LEADER 0 EFTP-BUFFER 0)
   T)
-
-(DEFUN EFTP-BINARY-FILE-TO-ALTO (FILENAME ALTO-ADDRESS)
-  (LET ((IN (GLOBAL:OPEN FILENAME '(:READ :FIXNUM :BYTE-SIZE 8)))
-        (OUT (MAKE-EFTP-WRITE-STREAM ALTO-ADDRESS T)))
-    (STREAM-COPY-UNTIL-EOF IN OUT)
-    (FUNCALL OUT ':CLOSE)
-    (FUNCALL IN ':CLOSE)))
 
 (DEFVAR EFTP-UNRCHF)
 
-(DEFUN MAKE-EFTP-READ-STREAM (EFTP-FOREIGN-HOST
-                               &OPTIONAL (EFTP-BINARY-P NIL) (EFTP-LOCAL-PORT 20))
+(DEFUN MAKE-EFTP-READ-STREAM (FOREIGN-HOST
+                               &OPTIONAL (EFTP-BINARY-P NIL) (LOCAL-PORT 20))
   (LET ((EFTP-NEXT-PUP-ID 0)
-        (EFTP-FOREIGN-PORT NIL) ;Set later
+        (EFTP-CONN (OPEN-FOREIGN-CONNECTION FOREIGN-HOST 0 10. LOCAL-PORT))
         (EFTP-UNRCHF NIL)
-        (EFTP-BUFFER (MAKE-ARRAY NIL 'ART-8B MAX-PUP-DATA-BYTES NIL '(0 0))))
-    (CLOSURE '(EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-UNRCHF EFTP-NEXT-PUP-ID
-               EFTP-LOCAL-PORT EFTP-BINARY-P EFTP-BUFFER)
+        (EFTP-BUFFER (MAKE-ARRAY MAX-PUP-DATA-BYTES ':TYPE 'ART-8B ':LEADER-LIST '(0 0))))
+    (CLOSURE '(EFTP-CONN EFTP-UNRCHF EFTP-NEXT-PUP-ID EFTP-BINARY-P EFTP-BUFFER)
              'EFTP-READ-STREAM)))
 
 (DEFUN EFTP-READ-STREAM (OP &OPTIONAL ARG1 &REST ARGS)
   (SELECTQ OP
-    (:WHICH-OPERATIONS '(:TYI :UNTYI))
+    (:WHICH-OPERATIONS '(:TYI :UNTYI :CLOSE))
     (:TYI (COND (EFTP-UNRCHF
                   (PROG1 EFTP-UNRCHF (SETQ EFTP-UNRCHF NIL)))
@@ -290 +238 @@
                                   (SETQ CH (EFTP-READ-STREAM OP ARG1))))))
                     CH))
-                ((AND EFTP-FOREIGN-HOST (EFTP-READ-NEXT-PUP))
+                ((AND EFTP-CONN (EFTP-READ-NEXT-PUP))
                   (EFTP-READ-STREAM OP ARG1))
                 (T ;Eof
-                  (SETQ EFTP-FOREIGN-HOST NIL)  ;Flag as eof
+                  (REMOVE-CONN EFTP-CONN)
+                  (SETQ EFTP-CONN NIL)          ;Flag as eof
                   (AND ARG1 (ERROR ARG1)))))
     (:UNTYI (SETQ EFTP-UNRCHF ARG1))
+    (:CLOSE (REMOVE-CONN EFTP-CONN))
     (OTHERWISE (STREAM-DEFAULT-HANDLER #'EFTP-READ-STREAM OP ARG1 ARGS))))
 
@@ -301 +251 @@
   "Returns NIL at eof, else sets up buffer"
   ;; EFTP-NEXT-PUP-ID has the number of the packet we are expecting to receive here
-  (AND EFTP-FOREIGN-PORT                ;Not first time, acknowledge previous packet
-       (TRANSMIT-PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-LOCAL-PORT
-                              31 (1- EFTP-NEXT-PUP-ID)) 0))
+  (AND (PLUSP EFTP-NEXT-PUP-ID)         ;Not first time, acknowledge previous packet
+       (TRANSMIT-PUP EFTP-CONN (GET-PUP EFTP-CONN 31 (1- EFTP-NEXT-PUP-ID)) 0))
   (DO ((N-TIMEOUTS 1 (1+ N-TIMEOUTS))
        (EOF-SEQUENCE-P NIL)
        (PUP))
       (NIL)                             ;Loop until receive data
-    (COND ((NULL (SETQ PUP (RECEIVE-PUP EFTP-LOCAL-PORT)))
+    (COND ((NULL (SETQ PUP (RECEIVE-PUP EFTP-CONN)))
            (COND ((ZEROP (\ N-TIMEOUTS 10.))
                   (AND EOF-SEQUENCE-P (RETURN NIL))     ;Done with dally timeout
                   (FORMAT ERROR-OUTPUT
-                          (IF EFTP-FOREIGN-PORT
+                          (IF (PLUSP EFTP-NEXT-PUP-ID)
                               "~&[Host has stopped sending, still trying...]~%"
-                              "~&[Host has not started sending, still trying...]~%"))))
-           (KBD-CHAR-AVAILABLE))
+                              "~&[Host has not started sending, still trying...]~%")))))
           ((NOT (AND (OR (= (PUP-TYPE PUP) 30) (= (PUP-TYPE PUP) 32) (= (PUP-TYPE PUP) 33))
-                     (= (PUP-SOURCE-HOST PUP) EFTP-FOREIGN-HOST)
-                     (OR (NULL EFTP-FOREIGN-PORT)
+                     (= (PUP-SOURCE-HOST PUP) (FOREIGN-ADDRESS EFTP-CONN))
+                     (OR (ZEROP EFTP-NEXT-PUP-ID)
                          (= (DPB (PUP-SOURCE-PORT-HIGH PUP) 2020 (PUP-SOURCE-PORT-LOW PUP))
-                            EFTP-FOREIGN-PORT))))
+                            (FOREIGN-INDEX-NUM EFTP-CONN)))))
            (RECEIVED-RANDOM-PUP PUP))
           ((= (PUP-TYPE PUP) 33)
            (FORMAT ERROR-OUTPUT "~&EFTP Abort~:[~; in eof sequence~], code ~D, ~A~%"
-                   EOF-SEQUENCE-P (AREF PUP 22.) (PUP-STRING PUP 2))
-           (FREE-INT-PKT PUP)
+                   EOF-SEQUENCE-P (PUP-WORD PUP 0) (PUP-STRING PUP 2))
+           (RETURN-PKT PUP)
            (BREAK EFTP-ABORT))
           ((NOT (= (DPB (PUP-ID-HIGH PUP) 2020 (PUP-ID-LOW PUP))
                    EFTP-NEXT-PUP-ID))
-           (FREE-INT-PKT PUP)           ;Ignore random old data
-           (AND EFTP-FOREIGN-PORT       ;Except repeat acknowledgement
-                (TRANSMIT-PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-LOCAL-PORT
-                                       31 (1- EFTP-NEXT-PUP-ID)) 0)))
+           (RETURN-PKT PUP)             ;Ignore random old data
+           (AND (PLUSP EFTP-NEXT-PUP-ID);Except repeat acknowledgement
+                (TRANSMIT-PUP EFTP-CONN (GET-PUP EFTP-CONN 31 (1- EFTP-NEXT-PUP-ID)) 0)))
           ((= (PUP-TYPE PUP) 32)        ;Eof
-           (FREE-INT-PKT PUP)
+           (RETURN-PKT PUP)
            (AND EOF-SEQUENCE-P (RETURN NIL))    ;Done dallying
            (SETQ EOF-SEQUENCE-P T)      ;Ack the EFTP-END packet
-           (TRANSMIT-PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-LOCAL-PORT
-                                  31 EFTP-NEXT-PUP-ID) 0)
+           (TRANSMIT-PUP EFTP-CONN (GET-PUP EFTP-CONN 31 EFTP-NEXT-PUP-ID) 0)
            (SETQ EFTP-NEXT-PUP-ID (1+ EFTP-NEXT-PUP-ID)))
           (T                            ;Incoming data
            (AND (> N-TIMEOUTS 9)
                 (FORMAT ERROR-OUTPUT "~&[Host has commenced transmission]~%"))
-           (AND (NULL EFTP-FOREIGN-PORT)
-                (SETQ EFTP-FOREIGN-PORT (DPB (PUP-SOURCE-PORT-HIGH PUP)
-                                             2020 (PUP-SOURCE-PORT-LOW PUP))))
+           (AND (ZEROP EFTP-NEXT-PUP-ID)
+                (SETF (FOREIGN-INDEX-NUM EFTP-CONN)
+                      (DPB (PUP-SOURCE-PORT-HIGH PUP) 2020 (PUP-SOURCE-PORT-LOW PUP))))
            (SETF (ARRAY-LEADER EFTP-BUFFER 1) 0)
-           (SETF (ARRAY-LEADER EFTP-BUFFER 0) (- (PUP-OVERALL-LENGTH PUP) 22.))
+           (SETF (ARRAY-LEADER EFTP-BUFFER 0) (- (PUP-OVERALL-LENGTH PUP) PUP-NON-DATA-BYTES))
            (DOTIMES (I (// (1+ (ARRAY-ACTIVE-LENGTH EFTP-BUFFER)) 2))
-             (LET ((WD (AREF PUP (+ I 22.))))
-               (ASET (LDB 1010 WD) EFTP-BUFFER (* I 2))
-               (ASET (LDB 0010 WD) EFTP-BUFFER (1+ (* I 2)))))
-           (FREE-INT-PKT PUP)
+             (LET ((WD (AREF PUP (+ I PUP-FIRST-DATA-WORD))))
+               (ASET (LDB 0010 WD) EFTP-BUFFER (* I 2))
+               (ASET (LDB 1010 WD) EFTP-BUFFER (1+ (* I 2)))))
+           (RETURN-PKT PUP)
            (SETQ EFTP-NEXT-PUP-ID (1+ EFTP-NEXT-PUP-ID))
            (RETURN T)))))
 
+(DEFUN EFTP-BINARY-FILE-TO-ALTO (FILENAME ALTO-ADDRESS)
+  (WITH-OPEN-FILE (IN FILENAME '(:READ :FIXNUM :BYTE-SIZE 8))
+    (LET ((OUT (MAKE-EFTP-WRITE-STREAM ALTO-ADDRESS T)))
+      (STREAM-COPY-UNTIL-EOF IN OUT)
+      (FUNCALL OUT ':CLOSE))))
+
 (DEFUN EFTP-BINARY-FILE-FROM-ALTO (FILENAME ALTO-ADDRESS)
-  (LET ((OUT (GLOBAL:OPEN FILENAME '(:WRITE :FIXNUM :BYTE-SIZE 8)))
-        (IN (MAKE-EFTP-READ-STREAM ALTO-ADDRESS T)))
-    (STREAM-COPY-UNTIL-EOF IN OUT)
-    (FUNCALL OUT ':CLOSE)))
-
+  (WITH-OPEN-FILE (OUT FILENAME '(:WRITE :FIXNUM :BYTE-SIZE 8))
+    (LET ((IN (MAKE-EFTP-READ-STREAM ALTO-ADDRESS T)))
+      (STREAM-COPY-UNTIL-EOF IN OUT))))
 
 (DEFUN EFTP-TEXT-FILE-FROM-ALTO (FILENAME ALTO-ADDRESS)
-  (LET ((OUT (GLOBAL:OPEN FILENAME '(:WRITE)))
-        (IN (MAKE-EFTP-READ-STREAM ALTO-ADDRESS)))
-    (STREAM-COPY-UNTIL-EOF IN OUT)
-    (FUNCALL OUT ':CLOSE)))
+  (WITH-OPEN-FILE (OUT FILENAME '(:WRITE))
+    (LET ((IN (MAKE-EFTP-READ-STREAM ALTO-ADDRESS)))
+      (STREAM-COPY-UNTIL-EOF IN OUT))))
 
 (DEFUN EFTP-TEXT-FILE-TO-ALTO (FILENAME ALTO-ADDRESS)
-  (LET ((IN (GLOBAL:OPEN FILENAME '(:READ)))
-        (OUT (MAKE-EFTP-WRITE-STREAM ALTO-ADDRESS)))
-    (STREAM-COPY-UNTIL-EOF IN OUT)
-    (FUNCALL IN ':CLOSE)
-    (FUNCALL OUT ':CLOSE)))
+  (WITH-OPEN-FILE (IN FILENAME '(:READ))
+    (LET ((OUT (MAKE-EFTP-WRITE-STREAM ALTO-ADDRESS)))
+      (STREAM-COPY-UNTIL-EOF IN OUT)
+      (FUNCALL OUT ':CLOSE))))
+

trunk/lisp/lmio1/fntcnv.lisp

@@ -1 @@
-;;;-*-Mode:LISP; Package:FED-*-
+;;; -*-Mode:LISP; Package:FED; Base:8-*-
+;;;  * (c) Copyright 1980 Massachusetts Institute of Technology **
+;;;  * Enhancements (c) copyright 1981 Symbolics, Inc. **
 
 ;The functions in this file
 ;are used to convert between the various formats for fonts as used on the LISP
-;Machine.  There are currently three formats supported:
+;Machine.  These are the formats currently supported in some way:
 ;       KST format is used for communication with the PDP-10.
 ;       FD (or Font Descriptor) Format is used as a machine resident format
 ;               which is easily manipulated.  The format consists of a 200
-;               element array with a leader.  The elements of this array are
+;               or more element array with a leader.  The elements of this array are
 ;               themselves two dimensional arrays which contain the actual
 ;               pixel values for the character.
@@ -15 +17 @@
 ;               be better.
 ;       AL format is used for ALTO fonts.
-
+;       AC another xerox format.
+;       KS kerned strike xerox format.
+;       AST stars and spaces.
+
+;Conversion functions:
+; FONT-INTO-FONT-DESCRIPTOR FONTNAME => FONT-DESCRIPTOR
+;  (you might really want FONT-NAME-FONT-DESCRIPTOR, which remembers the FONT-DESCRIPTOR)
+; FONT-DESCRIPTOR-INTO-FONT FONT-DESCRIPTOR => FONTNAME
+; READ-X-INTO-FONT FILENAME &OPTIONAL FONTNAME => FONTNAME
+; READ-X-INTO-FONT-DESCRIPTOR FILENAME &OPTIONAL FONTNAME => FONT-DESCRIPTOR
+; WRITE-FONT-INTO-X FONTNAME &OPTIONAL FILENAME => OUTPUT-TRUENAME
+; WRITE-FONT-DESCRIPTOR-INTO-X FONT-DESCRIPTOR &OPTIONAL FILENAME => OUTPUT-TRUENAME
+
+;Other useful functions in here:
+; THICKEN-FONT[-DESCRIPTOR], makes B(old) fonts.
+; ROTATE-FONT[-DESCRIPTOR], makes R(otated) fonts.  I.e. landscape from portrait.
+
+; CD-RASTER-RANGE CHAR-DESCRIPTOR => MINX MINY MAXX MAXY
+; CD-UNUSED-RASTER-HEIGHT CHAR-DESCRIPTOR => BOTTOM TOP
+
 ;First some helping functions:
 
 ;Maximum raster width of an FD format font
 (DEFUN MAX-RASTER-WIDTH (FONT-DESCRIPTOR &AUX (GUESS 0) TEMP)
-       (DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
-           ((
- CHAR-CODE 200) GUESS)
-           (COND ((SETQ TEMP (AR-1 FONT-DESCRIPTOR CHAR-CODE))
-                  (SETQ GUESS (MAX GUESS (ARRAY-DIMENSION-N 2 TEMP)))))))
+  (DO ((CHAR-CODE 0 (1+ CHAR-CODE))
+       (FONT-LENGTH (ARRAY-ACTIVE-LENGTH FONT-DESCRIPTOR)))
+      ((
+ CHAR-CODE FONT-LENGTH) GUESS)
+    (COND ((SETQ TEMP (AREF FONT-DESCRIPTOR CHAR-CODE))
+           (SETQ GUESS (MAX GUESS (ARRAY-DIMENSION-N 2 TEMP)))))))
 
 ;Maximum raster height of an FD format font
 (DEFUN MAX-RASTER-HEIGHT (FONT-DESCRIPTOR &AUX (GUESS 0) TEMP)
-       (DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
-           ((
- CHAR-CODE 200) GUESS)
-           (COND ((SETQ TEMP (AR-1 FONT-DESCRIPTOR CHAR-CODE))
-                  (SETQ GUESS (MAX GUESS (ARRAY-DIMENSION-N 1 TEMP)))))))
+  (DO ((CHAR-CODE 0 (1+ CHAR-CODE))
+       (FONT-LENGTH (ARRAY-ACTIVE-LENGTH FONT-DESCRIPTOR)))
+      ((
+ CHAR-CODE FONT-LENGTH) GUESS)
+    (COND ((SETQ TEMP (AREF FONT-DESCRIPTOR CHAR-CODE))
+           (SETQ GUESS (MAX GUESS (ARRAY-DIMENSION-N 1 TEMP)))))))
 
 ;;; Memoizing version of FONT-INTO-FONT-DESCRIPTOR
@@ -39 +62 @@
 ;;; The FONT-DESCRIBED property holds the font itself which the descriptor matches.
 ;;; If anyone changes the font, we can see that the old descriptor is no good.
-(defun font-name-font-descriptor (fontname &aux fd)
-    (setq fd (get fontname 'font-descriptor))
-    (cond ((and fd (eq (get fontname 'font-described) (symeval fontname))))
-          (t (setq fd (font-into-font-descriptor (symeval fontname)))
-             (putprop fontname (symeval fontname) 'font-described)
-             (putprop fontname fd 'font-descriptor)))
-    fd)
+(DEFUN FONT-NAME-FONT-DESCRIPTOR (FONTNAME &AUX FD)
+  (SETQ FD (GET FONTNAME 'FONT-DESCRIPTOR))
+  (COND ((AND FD (EQ (GET FONTNAME 'FONT-DESCRIBED) (SYMEVAL FONTNAME))))
+        (T (SETQ FD (FONT-INTO-FONT-DESCRIPTOR (SYMEVAL FONTNAME)))
+           (PUTPROP FONTNAME (SYMEVAL FONTNAME) 'FONT-DESCRIBED)
+           (PUTPROP FONTNAME FD 'FONT-DESCRIPTOR)))
+  FD)
 
 ;;; Set a font given a font descriptor.  Keep the descriptor around.
 ;;; Forward the old definition of the font to the new one.
-(defun font-name-set-font-and-descriptor (fontname font-descriptor)
-    (let ((oldfont (and (boundp fontname) (symeval fontname))))
-      (set fontname (font-descriptor-into-font font-descriptor))
-      (and oldfont (structure-forward oldfont (symeval fontname)))
-      (putprop fontname font-descriptor 'font-descriptor)
-      (putprop fontname (symeval fontname) 'font-described)
-      font-descriptor))
+(DEFUN FONT-NAME-SET-FONT-AND-DESCRIPTOR (FONTNAME FONT-DESCRIPTOR)
+  (LET ((OLDFONT (AND (BOUNDP FONTNAME) (SYMEVAL FONTNAME))))
+    (SET FONTNAME (FONT-DESCRIPTOR-INTO-FONT FONT-DESCRIPTOR))
+    (AND OLDFONT (STRUCTURE-FORWARD OLDFONT (SYMEVAL FONTNAME)))
+    (PUTPROP FONTNAME FONT-DESCRIPTOR 'FONT-DESCRIPTOR)
+    (PUTPROP FONTNAME (SYMEVAL FONTNAME) 'FONT-DESCRIBED)
+    FONT-DESCRIPTOR))
 
 ;Store a character in a font.  Given a font and corresponding FD, both are
@@ -61 +84 @@
 ;If the CD can be stored into the existing font, that is done.
 ;Otherwise, a new font is made from the updated FD and the old font forwarded to it.
-(defun font-name-store-cd (fontname cd char-code &aux font)
-    (let ((width (array-dimension-n 2 cd))
-          (height (array-dimension-n 1 cd))
-          tem fd)
-      (setq fd (font-name-font-descriptor fontname))
-      (as-1 cd fd char-code)
-      (and (= char-code #/ )
-           (setf (fd-space-width fd) (cd-char-width cd)))
-      (cond ((or (not (boundp fontname))
-                 (null (setq font (symeval fontname)))
-                 (> width
-                    (cond ((setq tem (font-indexing-table font))
-                           (* (font-raster-width font)
-                              (- (ar-1 tem (1+ char-code))
-                                 (ar-1 tem char-code))))
-                          (t (font-raster-width font))))
-                 (> height (font-raster-height font)))
-             (font-name-set-font-and-descriptor fontname fd))
-            (t (store-cd-in-font cd font char-code nil)))))
+(DEFUN FONT-NAME-STORE-CD (FONTNAME CD CHAR-CODE &AUX FONT)
+  (LET ((WIDTH (ARRAY-DIMENSION-N 2 CD))
+        (HEIGHT (ARRAY-DIMENSION-N 1 CD))
+        TEM FD)
+    (SETQ FD (FONT-NAME-FONT-DESCRIPTOR FONTNAME))
+    (FD-STORE-CD FD CD CHAR-CODE)
+    (AND (= CHAR-CODE #\SP)
+         (SETF (FD-SPACE-WIDTH FD) (CD-CHAR-WIDTH CD)))
+    (COND ((OR (NOT (BOUNDP FONTNAME))
+               (NULL (SETQ FONT (SYMEVAL FONTNAME)))
+               (
+ CHAR-CODE (MAX (OR (FONT-FILL-POINTER FONT) 200) 200))
+               (> WIDTH
+                  (COND ((SETQ TEM (FONT-INDEXING-TABLE FONT))
+                         (* (FONT-RASTER-WIDTH FONT)
+                            (- (AREF TEM (1+ CHAR-CODE))
+                               (AREF TEM CHAR-CODE))))
+                        (T (FONT-RASTER-WIDTH FONT))))
+               (> HEIGHT (FONT-RASTER-HEIGHT FONT)))
+           (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME FD))
+          (T (STORE-CD-IN-FONT CD FONT CHAR-CODE NIL)))))
+
+(DEFUN FD-STORE-CD (FD CD CH)
+  (AND (
+ CH (ARRAY-LENGTH FD))
+       (ADJUST-ARRAY-SIZE FD (+ CH 100)))
+  (AND (
+ CH (FD-FILL-POINTER FD))
+       (SETF (FD-FILL-POINTER FD) (1+ CH)))
+  (ASET CD FD CH))
 
 ;Functions for referring to specified pixels of characters in an internal format font.
@@ -88 +122 @@
 ;  (SETQ ROW (- (FONT-BASELINE FONT) ROW))
 ;  (AND (SETQ TEM (FONT-LEFT-KERN-TABLE FONT))
-;       (SETQ COL (+ COL (AR-1 TEM CHAR))))
+;       (SETQ COL (+ COL (AREF TEM CHAR))))
 ;However it looks like this would cause more trouble than it would save.
 ;Attempts to reference outside of the raster return 0, or barf if storing.
@@ -95 +129 @@
 (DEFUN FONT-GET-PIXEL (FONT CHAR ROW COL &AUX TEM (NEXTCHAR (1+ CHAR)))
   (COND ((OR (< ROW 0)
-             (>= ROW (FONT-RASTER-HEIGHT FONT))
+             (
+ ROW (FONT-RASTER-HEIGHT FONT))
              (< COL 0)
              (COND ((SETQ TEM (FONT-INDEXING-TABLE FONT))
-                    (SETQ CHAR (+ (AR-1 TEM CHAR) (// COL (FONT-RASTER-WIDTH FONT))))
+                    (SETQ CHAR (+ (AREF TEM CHAR) (// COL (FONT-RASTER-WIDTH FONT))))
                     (SETQ COL (\ COL (FONT-RASTER-WIDTH FONT)))
-                    (>= CHAR (AR-1 TEM NEXTCHAR)))
-                   ((>= COL (FONT-RASTER-WIDTH FONT)))))
-         0)  ;out of bounds, return 0
+                    (
+ CHAR (AREF TEM NEXTCHAR)))
+                   ((
+ COL (FONT-RASTER-WIDTH FONT)))))
+         0)     ;out of bounds, return 0
         (T
          (DO ((FONT FONT (FONT-NEXT-PLANE FONT))
@@ -109 +146 @@
              ((NULL FONT) PIXEL)
            (SETQ PIXEL
-                 (+ PIXEL (LSH (AR-1 FONT
+                 (+ PIXEL (LSH (AREF FONT
                                      (+ (* 32. (+ (* (FONT-WORDS-PER-CHAR FONT) CHAR)
                                                   (// ROW (FONT-RASTERS-PER-WORD FONT))))
@@ -119 +156 @@
 (DEFUN FONT-SET-PIXEL (PIXEL FONT CHAR ROW COL &AUX TEM (NEXTCHAR (1+ CHAR)))
   (COND ((OR (< ROW 0)
-             (>= ROW (FONT-RASTER-HEIGHT FONT))
+             (
+ ROW (FONT-RASTER-HEIGHT FONT))
              (< COL 0)
              (COND ((SETQ TEM (FONT-INDEXING-TABLE FONT))
-                    (SETQ CHAR (+ (AR-1 TEM CHAR) (// COL (FONT-RASTER-WIDTH FONT))))
+                    (SETQ CHAR (+ (AREF TEM CHAR) (// COL (FONT-RASTER-WIDTH FONT))))
                     (SETQ COL (\ COL (FONT-RASTER-WIDTH FONT)))
-                    (>= CHAR (AR-1 TEM NEXTCHAR)))
-                   ((>= COL (FONT-RASTER-WIDTH FONT)))))
+                    (
+ CHAR (AREF TEM NEXTCHAR)))
+                   ((
+ COL (FONT-RASTER-WIDTH FONT)))))
          (FERROR NIL "Store of ~C in ~S at ~O,~O out of character bounds" CHAR FONT ROW COL))
         (T
@@ -131 +171 @@
               (BIT PIXEL (LSH BIT -1)))
              ((NULL FONT) PIXEL)
-             (AS-1 BIT FONT
+             (ASET BIT FONT
                    (+ (* 32. (+ (* (FONT-WORDS-PER-CHAR FONT) CHAR)
                                 (// ROW (FONT-RASTERS-PER-WORD FONT))))
@@ -144 +184 @@
 
 (DEFUN FONT-DESCRIPTOR-INTO-FONT (FONT-DESCRIPTOR
-           &OPTIONAL (NBR-PLANES-OUT NIL)
-           &AUX (FONT-OUT NIL)
-                (COL-INCR (COND ((FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR) 2)
-                                (T 1)))
-                (SPACE-WIDTH (OR (FD-SPACE-WIDTH FONT-DESCRIPTOR) 0))
-                (WIDTH (// SPACE-WIDTH COL-INCR))
-                (HEIGHT (FD-LINE-SPACING FONT-DESCRIPTOR))
-                (BASELINE (FD-BASELINE FONT-DESCRIPTOR))
-                (RASTER-WIDTH (// (+ (MAX-RASTER-WIDTH FONT-DESCRIPTOR)
-                                     (1- COL-INCR))
-                                  COL-INCR))
-                (RASTER-HEIGHT (MAX-RASTER-HEIGHT FONT-DESCRIPTOR))
-                (RASTERS-PER-WORD (// 32. (MIN 32. RASTER-WIDTH)))
-                (WORDS-PER-RASTER-ELEMENT (1+ (// (1- RASTER-HEIGHT) RASTERS-PER-WORD)))
-                (TOTAL-RASTER-ELEMENTS 200)
-                (BLINKER-WIDTH (// (FD-BLINKER-WIDTH FONT-DESCRIPTOR) COL-INCR))
-                (BLINKER-HEIGHT (FD-BLINKER-HEIGHT FONT-DESCRIPTOR))
-                (INDEXING-TABLE NIL)
-                (CHARS-EXIST-TABLE (MAKE-ARRAY NIL ART-1B 200))
-                TEMP                                    ;General temporary
-                )
-
+       &OPTIONAL (NBR-PLANES-OUT NIL)
+       &AUX (FONT-OUT NIL)
+            (FONT-DESCRIPTOR-LENGTH (ARRAY-ACTIVE-LENGTH FONT-DESCRIPTOR))
+            (FONT-LENGTH (MAX FONT-DESCRIPTOR-LENGTH 200))
+            (COL-INCR (COND ((FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR) 2)
+                            (T 1)))
+            (SPACE-WIDTH (OR (FIX (+ (FD-SPACE-WIDTH FONT-DESCRIPTOR) 0.5)) 0))
+            (WIDTH (// SPACE-WIDTH COL-INCR))
+            (HEIGHT (FD-LINE-SPACING FONT-DESCRIPTOR))
+            (BASELINE (FD-BASELINE FONT-DESCRIPTOR))
+            (RASTER-WIDTH (// (+ (MAX-RASTER-WIDTH FONT-DESCRIPTOR)
+                                 (1- COL-INCR))
+                              COL-INCR))
+            (RASTER-HEIGHT (MAX-RASTER-HEIGHT FONT-DESCRIPTOR))
+            (RASTERS-PER-WORD (// 32. (MIN 32. RASTER-WIDTH)))
+            (WORDS-PER-RASTER-ELEMENT (1+ (// (1- RASTER-HEIGHT) RASTERS-PER-WORD)))
+            (TOTAL-RASTER-ELEMENTS FONT-LENGTH)
+            (BLINKER-WIDTH (// (FD-BLINKER-WIDTH FONT-DESCRIPTOR) COL-INCR))
+            (BLINKER-HEIGHT (FD-BLINKER-HEIGHT FONT-DESCRIPTOR))
+            (INDEXING-TABLE NIL)
+            (CHARS-EXIST-TABLE (MAKE-ARRAY FONT-LENGTH ':TYPE 'ART-1B))
+            TEMP                                ;General temporary
+            )
+  
 ;Set up NBR-PLANES-OUT if defaulted
-       (COND ((NULL NBR-PLANES-OUT)
-              (SETQ NBR-PLANES-OUT COL-INCR)))
-
+  (COND ((NULL NBR-PLANES-OUT)
+         (SETQ NBR-PLANES-OUT COL-INCR)))
+  
 ;Create INDEXING-TABLE if needed
-       (COND ((> RASTER-WIDTH 32.)
-                (SETQ INDEXING-TABLE (MAKE-ARRAY NIL 'ART-16B 201))
-                (AS-1 0 INDEXING-TABLE 0)
-                (DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
-                    ((
- CHAR-CODE 200) (SETQ TOTAL-RASTER-ELEMENTS (AR-1 INDEXING-TABLE 200)))
-                    (SETQ TEMP (AR-1 FONT-DESCRIPTOR CHAR-CODE))
-                    (AS-1 (+ (AR-1 INDEXING-TABLE CHAR-CODE)
-                             (COND ((NULL TEMP) 0)
-                                   (T (// (+ (ARRAY-DIMENSION-N 2 TEMP) 31.) 32.))))
-                          INDEXING-TABLE (1+ CHAR-CODE)))
-                (SETQ RASTER-WIDTH 32.)))
-
+  (COND ((> RASTER-WIDTH 32.)
+         (SETQ INDEXING-TABLE (MAKE-ARRAY (1+ FONT-LENGTH) ':TYPE 'ART-16B))
+         (ASET 0 INDEXING-TABLE 0)
+         (DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
+             ((
+ CHAR-CODE FONT-LENGTH)
+              (SETQ TOTAL-RASTER-ELEMENTS (AREF INDEXING-TABLE FONT-LENGTH)))
+           (SETQ TEMP (AND (< CHAR-CODE FONT-DESCRIPTOR-LENGTH)
+                           (AREF FONT-DESCRIPTOR CHAR-CODE)))
+           (ASET (+ (AREF INDEXING-TABLE CHAR-CODE)
+                    (COND ((NULL TEMP) 0)
+                          (T (// (+ (ARRAY-DIMENSION-N 2 TEMP) 31.) 32.))))
+                 INDEXING-TABLE (1+ CHAR-CODE)))
+         (SETQ RASTER-WIDTH 32.)))
+  
 ;set up all the planes of the font
-       (DO ((I NBR-PLANES-OUT (1- I)))
-           ((ZEROP I))
-
+  (DO ((I NBR-PLANES-OUT (1- I)))
+      ((ZEROP I))
+    
 ;Make up a (one-plane) font and make it's next plane be the last one we made
-           (SETQ TEMP (TV:MAKE-FONT MAKE-ARRAY (NIL 'ART-1B
-                                                    (* TOTAL-RASTER-ELEMENTS
-                                                       WORDS-PER-RASTER-ELEMENT 32.))))
-           (SETF (FONT-NEXT-PLANE TEMP) FONT-OUT)
-           (SETQ FONT-OUT TEMP)
-
+    (SETQ TEMP (TV:MAKE-FONT MAKE-ARRAY (:TYPE 'ART-1B
+                                               :LENGTH (* TOTAL-RASTER-ELEMENTS
+                                                          WORDS-PER-RASTER-ELEMENT 32.))))
+    (SETF (FONT-NEXT-PLANE TEMP) FONT-OUT)
+    (SETQ FONT-OUT TEMP)
+    
 ;Now set all the other fields in the leader
-           (SETF (FONT-NAME FONT-OUT) (FD-NAME FONT-DESCRIPTOR))
-           (SETF (FONT-CHAR-WIDTH FONT-OUT) WIDTH)
-           (SETF (FONT-CHAR-HEIGHT FONT-OUT) HEIGHT)
-           (SETF (FONT-RASTER-WIDTH FONT-OUT) RASTER-WIDTH)
-           (SETF (FONT-RASTER-HEIGHT FONT-OUT) RASTER-HEIGHT)
-           (SETF (FONT-RASTERS-PER-WORD FONT-OUT) RASTERS-PER-WORD)
-           (SETF (FONT-WORDS-PER-CHAR FONT-OUT) WORDS-PER-RASTER-ELEMENT)
-           (SETF (FONT-BASELINE FONT-OUT) BASELINE)
-           (SETF (FONT-BLINKER-WIDTH FONT-OUT) BLINKER-WIDTH)
-           (SETF (FONT-BLINKER-HEIGHT FONT-OUT) BLINKER-HEIGHT)
-           (SETF (FONT-NAME FONT-OUT) (FD-NAME FONT-DESCRIPTOR))
-           (SETF (FONT-CHARS-EXIST-TABLE FONT-OUT) CHARS-EXIST-TABLE)
-           (SETF (FONT-INDEXING-TABLE FONT-OUT) INDEXING-TABLE))
-       (DO ((CHAR-CODE 0 (1+ CHAR-CODE))) ((
- CHAR-CODE 200))
-           (SETQ TEMP (AR-1 FONT-DESCRIPTOR CHAR-CODE))
-           (COND (TEMP
-                  (STORE-CD-IN-FONT TEMP FONT-OUT CHAR-CODE
-                                    (FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR)))))
-       FONT-OUT)
+    (SETF (FONT-NAME FONT-OUT) (FD-NAME FONT-DESCRIPTOR))
+    (SETF (FONT-CHAR-WIDTH FONT-OUT) WIDTH)
+    (SETF (FONT-CHAR-HEIGHT FONT-OUT) HEIGHT)
+    (SETF (FONT-RASTER-WIDTH FONT-OUT) RASTER-WIDTH)
+    (SETF (FONT-RASTER-HEIGHT FONT-OUT) RASTER-HEIGHT)
+    (SETF (FONT-RASTERS-PER-WORD FONT-OUT) RASTERS-PER-WORD)
+    (SETF (FONT-WORDS-PER-CHAR FONT-OUT) WORDS-PER-RASTER-ELEMENT)
+    (SETF (FONT-BASELINE FONT-OUT) BASELINE)
+    (SETF (FONT-BLINKER-WIDTH FONT-OUT) BLINKER-WIDTH)
+    (SETF (FONT-BLINKER-HEIGHT FONT-OUT) BLINKER-HEIGHT)
+    (SETF (FONT-NAME FONT-OUT) (FD-NAME FONT-DESCRIPTOR))
+    (SETF (FONT-CHARS-EXIST-TABLE FONT-OUT) CHARS-EXIST-TABLE)
+    (SETF (FONT-INDEXING-TABLE FONT-OUT) INDEXING-TABLE)
+    (SETF (FONT-FILL-POINTER FONT-OUT) FONT-LENGTH))
+  (DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
+      ((
+ CHAR-CODE FONT-LENGTH))
+    (SETQ TEMP (AND (< CHAR-CODE FONT-DESCRIPTOR-LENGTH)
+                    (AREF FONT-DESCRIPTOR CHAR-CODE)))
+    (COND (TEMP
+           (STORE-CD-IN-FONT TEMP FONT-OUT CHAR-CODE
+                             (FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR)))))
+  FONT-OUT)
 
 ;Store the data in CD into character number CHAR-CODE of FONT.
@@ -221 +268 @@
 ;This is not recommended for users to call.
 (DEFUN STORE-CD-IN-FONT (CD FONT CHAR-CODE &OPTIONAL (DOUBLE-WIDTH-P NIL) &AUX
-                            (WIDTH (ARRAY-DIMENSION-N 2 CD))
-                            (HEIGHT (ARRAY-DIMENSION-N 1 CD))
-                            (FONT-HEIGHT (FONT-RASTER-HEIGHT FONT))
-                            (FONT-WIDTH (FONT-RASTER-WIDTH FONT))
-                            PIXEL
-                            (COL-INCR (COND (DOUBLE-WIDTH-P 2) (T 1))))
-    ;; Update the font's char-width-table, creating one if necessary.
-    (LET ((CW (// (+ (CD-CHAR-WIDTH CD)
-                     (1- COL-INCR))
-                  COL-INCR))
-          (FCW (FONT-CHAR-WIDTH FONT))
-          (FCWT (FONT-CHAR-WIDTH-TABLE FONT)))
-        (COND (FCWT
-               (AS-1 CW FCWT CHAR-CODE))
-              ((NOT (= CW FCW))
-               (SETF (FONT-CHAR-WIDTH-TABLE FONT)
-                     (SETQ FCWT (MAKE-ARRAY NIL ART-8B '(200))))
-               (AND DOUBLE-WIDTH-P
-                    (SETF (FONT-CHAR-WIDTH-TABLE (FONT-NEXT-PLANE FONT))
-                          FCWT))
-               (DO I 0 (1+ I) (= I 200)
-                  (AS-1 FCW FCWT I))
-               (AS-1 CW FCWT CHAR-CODE)))
-        (AND (= CHAR-CODE #/ )
-             (SETF (FONT-CHAR-WIDTH FONT) CW)))
-    ;; Update the font's left-kern table, creating one if necessary.
-    (LET ((CK (CD-CHAR-LEFT-KERN CD))
-          (FCKT (FONT-LEFT-KERN-TABLE FONT)))
-        (COND (FCKT (AS-1 CK FCKT CHAR-CODE))
-              ((NOT (ZEROP CK))
-               (SETF (FONT-LEFT-KERN-TABLE FONT)        ;MUST BE ART-32B BECAUSE LEFT-KERN
-                     (SETQ FCKT (MAKE-ARRAY NIL ART-32B '(200))))  ;CAN BE NEGATIVE
-               (AND DOUBLE-WIDTH-P
-                    (SETF (FONT-LEFT-KERN-TABLE (FONT-NEXT-PLANE FONT))
-                          FCKT))
-               (AS-1 CK FCKT CHAR-CODE))))
-    ;; Tell the font this char exists.
-    (ERRSET (AS-1 1 (FONT-CHARS-EXIST-TABLE FONT) CHAR-CODE) NIL)
-    ;; In wide fonts, the raster width depends on the character, and is a multiple of 32.
-    (COND ((FONT-INDEXING-TABLE FONT)
-           (SETQ FONT-WIDTH (* (// (+ (ARRAY-DIMENSION-N 2 CD) 31.) 32.) 32.))))
-    ;; Now copy the data.
-    (DO ((ROW 0 (1+ ROW)))
+                         (FONT-LENGTH (FONT-FILL-POINTER FONT))
+                         (WIDTH (ARRAY-DIMENSION-N 2 CD))
+                         (HEIGHT (ARRAY-DIMENSION-N 1 CD))
+                         (FONT-HEIGHT (FONT-RASTER-HEIGHT FONT))
+                         (FONT-WIDTH (FONT-RASTER-WIDTH FONT))
+                         PIXEL
+                         (COL-INCR (COND (DOUBLE-WIDTH-P 2) (T 1))))
+  (OR (AND FONT-LENGTH (
+ FONT-LENGTH 200))
+      (SETQ FONT-LENGTH 200))
+  ;; Update the font's char-width-table, creating one if necessary.
+  (LET ((CW (// (+ (FIX (+ (CD-CHAR-WIDTH CD) 0.5))
+                   (1- COL-INCR))
+                COL-INCR))
+        (FCW (FONT-CHAR-WIDTH FONT))
+        (FCWT (FONT-CHAR-WIDTH-TABLE FONT)))
+    (COND (FCWT
+           (ASET CW FCWT CHAR-CODE))
+          ((NOT (= CW FCW))
+           (SETF (FONT-CHAR-WIDTH-TABLE FONT)
+                 (SETQ FCWT (MAKE-ARRAY FONT-LENGTH ':TYPE 'ART-8B)))
+           (AND DOUBLE-WIDTH-P
+                (SETF (FONT-CHAR-WIDTH-TABLE (FONT-NEXT-PLANE FONT))
+                      FCWT))
+           (DO I 0 (1+ I) (= I FONT-LENGTH)
+               (ASET FCW FCWT I))
+           (ASET CW FCWT CHAR-CODE)))
+    (AND (= CHAR-CODE #\SP)
+         (SETF (FONT-CHAR-WIDTH FONT) CW)))
+  ;; Update the font's left-kern table, creating one if necessary.
+  (LET ((CK (CD-CHAR-LEFT-KERN CD))
+        (FCKT (FONT-LEFT-KERN-TABLE FONT)))
+    (COND (FCKT (ASET CK FCKT CHAR-CODE))
+          ((NOT (ZEROP CK))
+           (SETF (FONT-LEFT-KERN-TABLE FONT)    ;MUST BE ART-32B BECAUSE LEFT-KERN
+                 (SETQ FCKT (MAKE-ARRAY FONT-LENGTH ':TYPE ART-32B)))   ;CAN BE NEGATIVE
+           (AND DOUBLE-WIDTH-P
+                (SETF (FONT-LEFT-KERN-TABLE (FONT-NEXT-PLANE FONT))
+                      FCKT))
+           (ASET CK FCKT CHAR-CODE))))
+  ;; Tell the font this char exists.
+  (ERRSET (ASET 1 (FONT-CHARS-EXIST-TABLE FONT) CHAR-CODE) NIL)
+  ;; In wide fonts, the raster width depends on the character, and is a multiple of 32.
+  (COND ((FONT-INDEXING-TABLE FONT)
+         (SETQ FONT-WIDTH (* (// (+ (ARRAY-DIMENSION-N 2 CD) 31.) 32.) 32.))))
+  ;; Now copy the data.
+  (DO ((ROW 0 (1+ ROW))
+       (ONE-BIT-FONT (NULL (FONT-NEXT-PLANE FONT)))
+       (RASTER-WIDTH (FONT-RASTER-WIDTH FONT)))
+      ((
+ ROW FONT-HEIGHT))
+    (DO (
+         ;; Count columns in font descriptor.
+         (COL 0 (+ COL COL-INCR))
+         ;; Count columns in font.
+         (PIXEL-COL 0 (1+ PIXEL-COL))
+         ;; for one-bit fonts this is index in font itself of start of row.
+         ;; For multi-bit fonts it is not used.
+         (NEXT-BIT-FONT-INDEX
+           (+ (* 32. (+ (* (FONT-WORDS-PER-CHAR FONT)
+                           (IF (FONT-INDEXING-TABLE FONT)
+                               (AREF (FONT-INDEXING-TABLE FONT) CHAR-CODE)
+                               CHAR-CODE))
+                        (// ROW (FONT-RASTERS-PER-WORD FONT))))
+              (* (FONT-RASTER-WIDTH FONT)
+                 (\ ROW (FONT-RASTERS-PER-WORD FONT))))
+           (1+ NEXT-BIT-FONT-INDEX)))
         ((
- ROW FONT-HEIGHT))
-        (DO ((COL 0 (+ COL COL-INCR))
-             (PIXEL-COL 0 (1+ PIXEL-COL)))
-            ((
  PIXEL-COL FONT-WIDTH))
-            (SETQ PIXEL (COND ((OR (>= COL WIDTH) (>= ROW HEIGHT)) 0)
-                              (DOUBLE-WIDTH-P
-                               (+ (COND ((>= (1+ COL) WIDTH) 0)
-                                        (T (AR-2 CD ROW (1+ COL))))
-                                  (* 2 (AR-2 CD ROW COL))))
-                              (T (AR-2 CD ROW COL))))
-            (FONT-SET-PIXEL PIXEL FONT CHAR-CODE
-                            ROW PIXEL-COL))))
+      ;; Get pixel out of font descriptor.
+      ;; If font is "double width", two pixels of font descriptor
+      ;; are combined into one pixel for the font itself.
+      (SETQ PIXEL (COND ((OR (
+ COL WIDTH) (
+ ROW HEIGHT)) 0)
+                        (DOUBLE-WIDTH-P
+                         (+ (COND ((
+ (1+ COL) WIDTH) 0)
+                                  (T (AREF CD ROW (1+ COL))))
+                            (* 2 (AREF CD ROW COL))))
+                        (T (AREF CD ROW COL))))
+      ;; Store pixel into font.
+      ;; If pixels are only one bit and chars not too wide, use a short cut.
+      (COND (ONE-BIT-FONT
+             ;; In wide font, notice when our horizontal advance
+             ;; carries us into the "next character" of the many characters
+             ;; in the font which actually represent vertical strips of one character.
+             (AND (ZEROP (\ PIXEL-COL RASTER-WIDTH))
+                  (NOT (ZEROP PIXEL-COL))
+                  (SETQ NEXT-BIT-FONT-INDEX
+                        (- (+ NEXT-BIT-FONT-INDEX
+                              (* 32. (FONT-WORDS-PER-CHAR FONT)))
+                           RASTER-WIDTH)))
+             (ASET PIXEL FONT NEXT-BIT-FONT-INDEX))
+            (T
+             (FONT-SET-PIXEL PIXEL FONT CHAR-CODE
+                             ROW PIXEL-COL))))))
 
 ;Create an FD format font from an internal format font
 
 (DEFUN FONT-INTO-FONT-DESCRIPTOR (FONT &OPTIONAL (DBL-WIDTH-P NIL)
-                   &AUX (FONT-DESCRIPTOR (MAKE-FONT-DESCRIPTOR))
-                        (LINE-SPACING (FONT-CHAR-HEIGHT FONT))
-                        (RASTER-HEIGHT (FONT-RASTER-HEIGHT FONT))
-                        (BASELINE (FONT-BASELINE FONT))
-                        (BLINKER-HEIGHT (FONT-BLINKER-HEIGHT FONT))
-                        (BLINKER-WIDTH (FONT-BLINKER-WIDTH FONT))
-                        (SPACE-WIDTH (FONT-CHAR-WIDTH FONT))
-                        FONT-CHARS-EXIST-TABLE
-                        TEMP RASTER-WIDTH CHARACTER-WIDTH LEFT-KERN PIXEL
-                        )
-       (ERRSET (SETQ FONT-CHARS-EXIST-TABLE (FONT-CHARS-EXIST-TABLE FONT)) NIL)
-       (SETF (FD-NAME FONT-DESCRIPTOR) (FONT-NAME FONT))
-       (SETF (FD-LINE-SPACING FONT-DESCRIPTOR) LINE-SPACING)
-       (SETF (FD-BASELINE FONT-DESCRIPTOR)BASELINE)
-       (SETF (FD-BLINKER-HEIGHT FONT-DESCRIPTOR) BLINKER-HEIGHT)
-       (SETF (FD-BLINKER-WIDTH FONT-DESCRIPTOR) BLINKER-WIDTH)
-       (SETF (FD-SPACE-WIDTH FONT-DESCRIPTOR) SPACE-WIDTH)
-       (SETF (FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR) DBL-WIDTH-P)
-       (DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
-           ((
- CHAR-CODE 200))
-           (AND FONT-CHARS-EXIST-TABLE
-                (ZEROP (AR-1 FONT-CHARS-EXIST-TABLE CHAR-CODE))
-                (GO SKIP-CHAR))
-           (SETQ CHARACTER-WIDTH (COND ((SETQ TEMP (FONT-CHAR-WIDTH-TABLE FONT))
-                                        (AR-1 TEMP CHAR-CODE))
-                                       (T (FONT-CHAR-WIDTH FONT))))
-           (SETQ RASTER-WIDTH
-                 (FONT-CHAR-MIN-RASTER-WIDTH FONT CHAR-CODE))
-           (SETQ LEFT-KERN (COND ((SETQ TEMP (FONT-LEFT-KERN-TABLE FONT))
-                                  (AR-1 TEMP CHAR-CODE))
-                                 (T 0)))
-           (SETQ TEMP (MAKE-CHAR-DESCRIPTOR
-                               MAKE-ARRAY (NIL 'ART-4B (LIST RASTER-HEIGHT RASTER-WIDTH))
-                               CD-CHAR-WIDTH CHARACTER-WIDTH
-                               CD-CHAR-LEFT-KERN LEFT-KERN))
-           (AS-1 TEMP FONT-DESCRIPTOR CHAR-CODE)
-           (COND (DBL-WIDTH-P (DO ((ROW 0 (1+ ROW)))
-                                  ((
+       &AUX FONT-DESCRIPTOR
+            (FONT-LENGTH (FONT-FILL-POINTER FONT))
+            (LINE-SPACING (FONT-CHAR-HEIGHT FONT))
+            (RASTER-HEIGHT (FONT-RASTER-HEIGHT FONT))
+            (BASELINE (FONT-BASELINE FONT))
+            (BLINKER-HEIGHT (FONT-BLINKER-HEIGHT FONT))
+            (BLINKER-WIDTH (FONT-BLINKER-WIDTH FONT))
+            (SPACE-WIDTH (FONT-CHAR-WIDTH FONT))
+            FONT-CHARS-EXIST-TABLE
+            TEMP RASTER-WIDTH CHARACTER-WIDTH LEFT-KERN PIXEL
+            )
+  (ERRSET (SETQ FONT-CHARS-EXIST-TABLE (FONT-CHARS-EXIST-TABLE FONT)) NIL)
+  ;; Correct for old fonts that may not have valid fill pointers.
+  (OR (AND FONT-LENGTH (
+ FONT-LENGTH 200))
+      (SETQ FONT-LENGTH 200))
+  (SETQ FONT-DESCRIPTOR (MAKE-FONT-DESCRIPTOR MAKE-ARRAY (:LENGTH FONT-LENGTH)
+                                              FD-FILL-POINTER FONT-LENGTH))
+  (SETF (FD-NAME FONT-DESCRIPTOR) (FONT-NAME FONT))
+  (SETF (FD-LINE-SPACING FONT-DESCRIPTOR) LINE-SPACING)
+  (SETF (FD-BASELINE FONT-DESCRIPTOR)BASELINE)
+  (SETF (FD-BLINKER-HEIGHT FONT-DESCRIPTOR) BLINKER-HEIGHT)
+  (SETF (FD-BLINKER-WIDTH FONT-DESCRIPTOR) BLINKER-WIDTH)
+  (SETF (FD-SPACE-WIDTH FONT-DESCRIPTOR) SPACE-WIDTH)
+  (SETF (FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR) DBL-WIDTH-P)
+  (DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
+      ((
+ CHAR-CODE FONT-LENGTH))
+    (AND FONT-CHARS-EXIST-TABLE
+         (ZEROP (AREF FONT-CHARS-EXIST-TABLE CHAR-CODE))
+         (GO SKIP-CHAR))
+    (SETQ CHARACTER-WIDTH (COND ((SETQ TEMP (FONT-CHAR-WIDTH-TABLE FONT))
+                                 (AREF TEMP CHAR-CODE))
+                                (T (FONT-CHAR-WIDTH FONT))))
+    (SETQ RASTER-WIDTH
+          (FONT-CHAR-MIN-RASTER-WIDTH FONT CHAR-CODE))
+    ;; If we don't know for sure which chars exist,
+    ;; discard chars containing no information.
+    (AND (NULL FONT-CHARS-EXIST-TABLE)
+         (ZEROP RASTER-WIDTH)
+         ( CHAR-CODE #\SPACE)
+         (= CHARACTER-WIDTH (FONT-CHAR-WIDTH FONT))
+         (GO SKIP-CHAR))
+    (SETQ LEFT-KERN (COND ((SETQ TEMP (FONT-LEFT-KERN-TABLE FONT))
+                           (AREF TEMP CHAR-CODE))
+                          (T 0)))
+    (SETQ TEMP (MAKE-CHAR-DESCRIPTOR
+                 MAKE-ARRAY (:TYPE 'ART-4B
+                                   :LENGTH (LIST RASTER-HEIGHT RASTER-WIDTH))
+                 CD-CHAR-WIDTH CHARACTER-WIDTH
+                 CD-CHAR-LEFT-KERN LEFT-KERN))
+    (ASET TEMP FONT-DESCRIPTOR CHAR-CODE)
+    (COND (DBL-WIDTH-P (DO ((ROW 0 (1+ ROW)))
+                           ((
  ROW RASTER-HEIGHT))
-                                  (DO ((COLI 0 (1+ COLI))
-                                       (COL 0 (+ 2 COL)))
-                                      ((
+                         (DO ((COLI 0 (1+ COLI))
+                              (COL 0 (+ 2 COL)))
+                             ((
  COL RASTER-WIDTH))
-                                      (SETQ PIXEL (FONT-GET-PIXEL FONT CHAR-CODE ROW COLI))
-                                      (AS-2 PIXEL TEMP ROW COL)
-                                      (AS-2 (LSH PIXEL -1) TEMP ROW (1+ COL)))))
-                 (T (DO ((ROW 0 (1+ ROW)))
-                        ((
+                           (SETQ PIXEL (FONT-GET-PIXEL FONT CHAR-CODE ROW COLI))
+                           (ASET PIXEL TEMP ROW COL)
+                           (ASET (LSH PIXEL -1) TEMP ROW (1+ COL)))))
+          (T (DO ((ROW 0 (1+ ROW)))
+                 ((
  ROW RASTER-HEIGHT))
-                        (DO ((COL 0 (1+ COL)))
-                            ((
+               (DO ((COL 0 (1+ COL)))
+                   ((
  COL RASTER-WIDTH))
-                            (AS-2 (FONT-GET-PIXEL FONT CHAR-CODE ROW COL)
-                                  TEMP ROW COL)))))
-           SKIP-CHAR)
-       FONT-DESCRIPTOR)
+                 (ASET (FONT-GET-PIXEL FONT CHAR-CODE ROW COL)
+                       TEMP ROW COL)))))
+    SKIP-CHAR)
+  FONT-DESCRIPTOR)
 
+;; Given filename and fontname from filename &optional fontname, canonicalize them
+(DEFUN GET-INPUT-FILENAME-AND-FONTNAME (FILENAME FONTNAME FILE-TYPE)
+  (DECLARE (RETURN-LIST FILENAME FONTNAME))
+  (SETQ FILENAME (FS:MERGE-PATHNAME-DEFAULTS FILENAME (PATHNAME-DEFAULTS) FILE-TYPE))
+  (OR FONTNAME (SETQ FONTNAME (FUNCALL FILENAME ':NAME)))
+  (AND (STRINGP FONTNAME) (SETQ FONTNAME (INTERN (STRING-UPCASE FONTNAME) "FONTS")))
+  (VALUES FILENAME FONTNAME))
+
 ;; Read in a kst file and make and return a FONT-DESCRIPTOR,
 ;; which is an alternate convenient representation for a font.
-(defun read-kst-into-font-descriptor (filename &optional fontname &aux stream fd)
-  (setq filename (fs:file-parse-name filename nil t ':kst))
-  (or fontname (setq fontname (funcall filename ':name)))
-  (and (stringp fontname) (setq fontname (intern fontname "FONTS")))
-  (setq stream (open filename '(:fixnum :in :byte-size 9.)))
-  (setq fd (make-font-descriptor fd-name fontname))
-  ;; Discard KSTID.
-  (dotimes (i 4) (funcall stream ':tyi))
-  ;; Discard column position adjust until I find out what it means.
-  (or (zerop (funcall stream ':tyi))
-      (ferror nil
-              "Nonzero column-position-adjust in font ~A -- what does that mean?"
-              fontname))
-  (setf (fd-space-width fd) 0)                  ;Just in case no space character.
-  (setf (fd-baseline fd) (funcall stream ':tyi))
-  (setf (fd-line-spacing fd) (read-kst-halfword stream))
-  (setf (fd-blinker-height fd)
-        (fd-line-spacing fd))
-  (setf (fd-name fd) fontname)
-  (let (kern char-code raster-width char-width byte-list byte-list-head cd tem
-             (line-height (fd-line-spacing fd)))
-    (do () ((= (logand (read-kst-halfword stream) (read-kst-halfword stream)) -1))
-      (setq kern (read-kst-halfword stream))
-      (setq char-code (read-kst-halfword stream))
-      (setq raster-width (read-kst-halfword stream))
-      (setq char-width (read-kst-halfword stream))
-      (setq cd (make-char-descriptor
-                 make-array (nil art-1b (list line-height raster-width))))
-      (setf (cd-char-width cd) char-width)
-      (setf (cd-char-left-kern cd) kern)
-      (as-1 cd fd char-code)
-      (and (= char-code #/ )
-           (setf (fd-space-width fd) char-width))
-      ;; read in the bits of the character
-      (setq byte-list nil
-            byte-list-head (list nil nil nil nil))
-      (dotimes (vpos line-height)
-        ;; Read in the next row.
-        (dotimes (hpos raster-width)
-          ;; If byte is exhausted, get next byte into (car byte-list)
-          (cond ((zerop (\ hpos 8))
-                 (setq byte-list (read-kst-bytes stream byte-list byte-list-head))))
-          (setq tem (logand 1 (lsh (car byte-list) (- (\ hpos 8)))))
-          (as-2 tem cd vpos hpos)))))
-  (setf (fd-fill-pointer fd) 200)
-  ;; Set width of blinker and space fields from the space character.
-  (setf (fd-blinker-width fd)
-        (fd-space-width fd))
-  (funcall stream ':close)
-  fd)
+(DEFUN READ-KST-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME &AUX FD)
+  (MULTIPLE-VALUE (FILENAME FONTNAME)
+    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "KST"))
+  (WITH-OPEN-FILE (STREAM FILENAME '(:FIXNUM :IN :BYTE-SIZE 9.))
+    (SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME MAKE-ARRAY (:LENGTH 200)))
+    ;; Discard KSTID.
+    (DOTIMES (I 4) (FUNCALL STREAM ':TYI))
+    ;; Discard column position adjust until I find out what it means.
+    (OR (ZEROP (FUNCALL STREAM ':TYI))
+        (FERROR NIL
+                "Nonzero column-position-adjust in font ~A -- what does that mean?"
+                FONTNAME))
+    (SETF (FD-SPACE-WIDTH FD) 0)                ;Just in case no space character.
+    (SETF (FD-BASELINE FD) (FUNCALL STREAM ':TYI))
+    (SETF (FD-LINE-SPACING FD) (READ-KST-HALFWORD STREAM))
+    (SETF (FD-BLINKER-HEIGHT FD)
+          (FD-LINE-SPACING FD))
+    (SETF (FD-NAME FD) FONTNAME)
+    (LET (KERN CHAR-CODE RASTER-WIDTH CHAR-WIDTH BYTE-LIST BYTE-LIST-HEAD CD TEM
+          (LINE-HEIGHT (FD-LINE-SPACING FD)))
+      (LOOP AS HEADER = (LOGIOR (ASH (READ-KST-HALFWORD STREAM) 18.)
+                                (READ-KST-HALFWORD STREAM))
+            UNTIL (= HEADER -1)
+            UNLESS (= HEADER 1)
+              DO (FERROR NIL "~O where character header expected; KST file misformatted"
+                             HEADER)
+        DO
+        (SETQ KERN (READ-KST-HALFWORD STREAM))
+        (SETQ CHAR-CODE (READ-KST-HALFWORD STREAM))
+        (SETQ RASTER-WIDTH (READ-KST-HALFWORD STREAM))
+        (SETQ CHAR-WIDTH (READ-KST-HALFWORD STREAM))
+        (SETQ CD (MAKE-CHAR-DESCRIPTOR
+                   MAKE-ARRAY (:TYPE ART-1B :LENGTH (LIST LINE-HEIGHT RASTER-WIDTH))))
+        (SETF (CD-CHAR-WIDTH CD) CHAR-WIDTH)
+        (SETF (CD-CHAR-LEFT-KERN CD) KERN)
+        (FD-STORE-CD FD CD CHAR-CODE)
+        (AND (= CHAR-CODE #\SP)
+             (SETF (FD-SPACE-WIDTH FD) CHAR-WIDTH))
+        ;; read in the bits of the character
+        (SETQ BYTE-LIST NIL
+              BYTE-LIST-HEAD (LIST NIL NIL NIL NIL))
+        (DOTIMES (VPOS LINE-HEIGHT)
+          ;; Read in the next row.
+          (DOTIMES (HPOS RASTER-WIDTH)
+            ;; If byte is exhausted, get next byte into (car byte-list)
+            (COND ((ZEROP (\ HPOS 8))
+                   (SETQ BYTE-LIST (READ-KST-BYTES STREAM BYTE-LIST BYTE-LIST-HEAD))))
+            (SETQ TEM (LOGAND 1 (LSH (CAR BYTE-LIST) (- (\ HPOS 8)))))
+            (ASET TEM CD VPOS HPOS)))))
+    ;; Truncate fd to discard unused elements at the end.
+    (DO ((I (1- (ARRAY-LENGTH FD)) (1- I)))
+        ((OR (MINUSP I)
+             (AREF FD I))
+         (ADJUST-ARRAY-SIZE FD (1+ I))))
+    (SETF (FD-FILL-POINTER FD) (ARRAY-LENGTH FD))
+    ;; Set width of blinker and space fields from the space character.
+    (SETF (FD-BLINKER-WIDTH FD)
+          (FD-SPACE-WIDTH FD)))
+  FD)
 
 ;; Read in a kst file and define a font.
 ;; The font name defaults from the file name.
-(defun read-kst-into-font (filename &optional fontname
-                                    &aux stream font chars-exist-table
-                                    raster-width raster-height
-                                    rasters-per-word words-per-char)
-    (setq filename (fs:file-parse-name filename nil t ':kst))
-    (or fontname (setq fontname (funcall filename ':name)))
-    (and (stringp fontname) (setq fontname (intern fontname "FONTS")))
-    ;; Read file once to determine font parameters.
-    (multiple-value (raster-width raster-height)
-                    (read-kst-max-raster-width filename))
-    ;; If this is a hairy wide font, then instead of writing it directly
-    ;; make a font-descriptor and turn it into a font.
-    (cond ((> raster-width 32.)
-           (font-name-set-font-and-descriptor
-               fontname
-               (read-kst-into-font-descriptor filename fontname))
-           fontname)
-          (t
-           (setq rasters-per-word (// 32. raster-width))
-           (setq words-per-char (// (+ raster-height rasters-per-word -1) rasters-per-word))
-           ;; Now that we know the parameters, allocate the font.
-           (setq font (tv:make-font make-array (nil art-1b (* words-per-char 32. 200))))
-           (setf (font-rasters-per-word font) rasters-per-word)
-           (setf (font-words-per-char font) words-per-char)
-           (setf (font-raster-width font) raster-width)
-           (setf (font-raster-height font) raster-height)
-           (setf (font-char-height font) raster-height)
-           (setf (font-blinker-height font) raster-height)
-           (setf (font-name font) fontname)
-           (setq chars-exist-table (make-array nil art-1b 200))
-           (setf (font-chars-exist-table font) chars-exist-table)
-           ;; Now actually read in the data of the font.
-           (setq stream (open filename '(:fixnum :in :byte-size 9.)))
+;;;??? This still assumes that the font length is no more than 200!
+;;; It seems hard to fix this.
+(DEFUN READ-KST-INTO-FONT (FILENAME &OPTIONAL FONTNAME
+                                    &AUX FONT CHARS-EXIST-TABLE
+                                         RASTER-WIDTH RASTER-HEIGHT
+                                         RASTERS-PER-WORD WORDS-PER-CHAR)
+  (MULTIPLE-VALUE (FILENAME FONTNAME)
+    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "KST"))
+  ;; Read file once to determine font parameters.
+  (MULTIPLE-VALUE (RASTER-WIDTH RASTER-HEIGHT)
+    (READ-KST-MAX-RASTER-WIDTH FILENAME))
+  ;; If this is a hairy wide font, then instead of writing it directly
+  ;; make a font-descriptor and turn it into a font.
+  (COND ((> RASTER-WIDTH 32.)
+         (FONT-NAME-SET-FONT-AND-DESCRIPTOR
+           FONTNAME
+           (READ-KST-INTO-FONT-DESCRIPTOR FILENAME FONTNAME))
+         FONTNAME)
+        (T
+         (SETQ RASTERS-PER-WORD (// 32. RASTER-WIDTH))
+         (SETQ WORDS-PER-CHAR (// (+ RASTER-HEIGHT RASTERS-PER-WORD -1) RASTERS-PER-WORD))
+         ;; Now that we know the parameters, allocate the font.
+         (SETQ FONT (TV:MAKE-FONT MAKE-ARRAY (:TYPE 'ART-1B
+                                                    :LENGTH (* WORDS-PER-CHAR 32. 200))))
+         (SETF (FONT-RASTERS-PER-WORD FONT) RASTERS-PER-WORD)
+         (SETF (FONT-WORDS-PER-CHAR FONT) WORDS-PER-CHAR)
+         (SETF (FONT-RASTER-WIDTH FONT) RASTER-WIDTH)
+         (SETF (FONT-RASTER-HEIGHT FONT) RASTER-HEIGHT)
+         (SETF (FONT-CHAR-HEIGHT FONT) RASTER-HEIGHT)
+         (SETF (FONT-BLINKER-HEIGHT FONT) RASTER-HEIGHT)
+         (SETF (FONT-NAME FONT) FONTNAME)
+         (SETQ CHARS-EXIST-TABLE (MAKE-ARRAY 200 ':TYPE 'ART-1B))
+         (SETF (FONT-CHARS-EXIST-TABLE FONT) CHARS-EXIST-TABLE)
+         ;; Now actually read in the data of the font.
+         (WITH-OPEN-FILE (STREAM FILENAME '(:FIXNUM :IN :BYTE-SIZE 9.))
            ;; Discard KSTID.
-           (dotimes (i 4) (funcall stream ':tyi))
+           (DOTIMES (I 4) (FUNCALL STREAM ':TYI))
            ;; Discard column position adjust until I find out what it means.
-           (or (zerop (funcall stream ':tyi))
-               (ferror nil
+           (OR (ZEROP (FUNCALL STREAM ':TYI))
+               (FERROR NIL
                        "Nonzero column-position-adjust in font ~A -- what does that mean?"
-                       fontname))
-           (setf (font-baseline font) (funcall stream ':tyi))
+                       FONTNAME))
+           (SETF (FONT-BASELINE FONT) (FUNCALL STREAM ':TYI))
            ;; Discard line height (already determined).
-           (read-kst-halfword stream)
-           (let (kern char-code char-width char-raster-width
-                      byte-list byte-list-head tem bit-pos word-pos
-                      (line-height raster-height))
-               (do () ((= (logand (read-kst-halfword stream) (read-kst-halfword stream)) -1))
-                   (setq kern (read-kst-halfword stream))
-                   (setq char-code (read-kst-halfword stream))
-                   ;; While all chars have the same raster width in the lisp machine font,
-                   ;; we need the raster width stored in the kst file to read the kst file.
-                   (setq char-raster-width (read-kst-halfword stream))
-                   (setq char-width (read-kst-halfword stream))
-                   (as-1 1 chars-exist-table char-code)
-                   ;; Now store the char width and left kern, creating the tables if nec.
-                   (cond ((null (font-char-width font))
-                          (setf (font-char-width font) char-width))
-                         ((font-char-width-table font)
-                          (as-1 char-width (font-char-width-table font) char-code))
-                         ((= char-width (font-char-width font)))
-                         (t (setf (font-char-width-table font)
-                                  (make-array nil art-16b 200))
-                            (as-1 char-width (font-char-width-table font) char-code)))
-                   (and (= char-code #/ )
-                        (setf (font-char-width font) char-width))
-                   (cond ((not (zerop kern))
-                          (or (font-left-kern-table font)
-                              (setf (font-left-kern-table font)
-                                    ;; Use art-32b so can hold both signs.
-                                    (make-array nil art-32b 200)))
-                          (as-1 kern (font-left-kern-table font) char-code)))
-                   ;; read in the bits of the character
-                   (setq byte-list nil
-                         byte-list-head (list nil nil nil nil))
-                   (setq word-pos (* char-code words-per-char)
-                         bit-pos 0)
-                   (dotimes (vpos line-height)
-                      ;; Find next row in font - advance to word boundary if nec.
-                      (and (> (+ bit-pos raster-width) 32.)
-                           (setq bit-pos 0 word-pos (1+ word-pos)))
-                      ;; Read in that row.
-                      (dotimes (hpos char-raster-width)
-                         ;; If byte is exhausted, get next byte into (car byte-list)
-                         (cond ((zerop (\ hpos 8))
-                                (setq byte-list (read-kst-bytes stream byte-list byte-list-head))))
-                         (setq tem (logand 1 (lsh (car byte-list) (- (\ hpos 8)))))
-                         (as-1 tem font (+ (lsh word-pos 5) bit-pos hpos)))
-                      ;; Advance past this row in the font.
-                      (setq bit-pos (+ bit-pos raster-width)))
-                   ))
-           ;; Set width of blinker and space fields from the space character.
-           (setf (font-blinker-width font)
-                 (font-char-width font))
-           (set fontname font)
-           (putprop fontname filename 'kst-file)
-           (funcall stream ':close)
-           fontname)))
+           (READ-KST-HALFWORD STREAM)
+           (LET (KERN CHAR-CODE CHAR-WIDTH CHAR-RASTER-WIDTH
+                 BYTE-LIST BYTE-LIST-HEAD TEM BIT-POS WORD-POS
+                 (LINE-HEIGHT RASTER-HEIGHT))
+             (LOOP AS HEADER = (LOGIOR (ASH (READ-KST-HALFWORD STREAM) 18.)
+                                       (READ-KST-HALFWORD STREAM))
+                   UNTIL (= HEADER -1)
+                   UNLESS (= HEADER 1)
+                     DO (FERROR NIL
+                                "~O where character header expected; KST file misformatted"
+                                HEADER)
+               DO
+               (SETQ KERN (READ-KST-HALFWORD STREAM))
+               (SETQ CHAR-CODE (READ-KST-HALFWORD STREAM))
+               ;; While all chars have the same raster width in the lisp machine font,
+               ;; we need the raster width stored in the kst file to read the kst file.
+               (SETQ CHAR-RASTER-WIDTH (READ-KST-HALFWORD STREAM))
+               (SETQ CHAR-WIDTH (READ-KST-HALFWORD STREAM))
+               (ASET 1 CHARS-EXIST-TABLE CHAR-CODE)
+               ;; Now store the char width and left kern, creating the tables if nec.
+               (COND ((NULL (FONT-CHAR-WIDTH FONT))
+                      (SETF (FONT-CHAR-WIDTH FONT) CHAR-WIDTH))
+                     ((FONT-CHAR-WIDTH-TABLE FONT)
+                      (ASET CHAR-WIDTH (FONT-CHAR-WIDTH-TABLE FONT) CHAR-CODE))
+                     ((= CHAR-WIDTH (FONT-CHAR-WIDTH FONT)))
+                     (T (SETF (FONT-CHAR-WIDTH-TABLE FONT)
+                              (MAKE-ARRAY 200 ':TYPE 'ART-16B))
+                        (ASET CHAR-WIDTH (FONT-CHAR-WIDTH-TABLE FONT) CHAR-CODE)))
+               (AND (= CHAR-CODE #\SP)
+                    (SETF (FONT-CHAR-WIDTH FONT) CHAR-WIDTH))
+               (COND ((NOT (ZEROP KERN))
+                      (OR (FONT-LEFT-KERN-TABLE FONT)
+                          (SETF (FONT-LEFT-KERN-TABLE FONT)
+                                ;; Use art-32b so can hold both signs.
+                                (MAKE-ARRAY 200 ':TYPE 'ART-32B)))
+                      (ASET KERN (FONT-LEFT-KERN-TABLE FONT) CHAR-CODE)))
+               ;; read in the bits of the character
+               (SETQ BYTE-LIST NIL
+                     BYTE-LIST-HEAD (LIST NIL NIL NIL NIL))
+               (SETQ WORD-POS (* CHAR-CODE WORDS-PER-CHAR)
+                     BIT-POS 0)
+               (DOTIMES (VPOS LINE-HEIGHT)
+                 ;; Find next row in font - advance to word boundary if nec.
+                 (AND (> (+ BIT-POS RASTER-WIDTH) 32.)
+                      (SETQ BIT-POS 0 WORD-POS (1+ WORD-POS)))
+                 ;; Read in that row.
+                 (DOTIMES (HPOS CHAR-RASTER-WIDTH)
+                   ;; If byte is exhausted, get next byte into (car byte-list)
+                   (COND ((ZEROP (\ HPOS 8))
+                          (SETQ BYTE-LIST (READ-KST-BYTES STREAM BYTE-LIST
+                                                          BYTE-LIST-HEAD))))
+                   (SETQ TEM (LOGAND 1 (LSH (CAR BYTE-LIST) (- (\ HPOS 8)))))
+                   (ASET TEM FONT (+ (LSH WORD-POS 5) BIT-POS HPOS)))
+                 ;; Advance past this row in the font.
+                 (SETQ BIT-POS (+ BIT-POS RASTER-WIDTH)))
+               )))
+         ;; Set width of blinker and space fields from the space character.
+         (SETF (FONT-BLINKER-WIDTH FONT)
+               (FONT-CHAR-WIDTH FONT))
+         (SET FONTNAME FONT)
+         (PUTPROP FONTNAME FILENAME 'KST-FILE)
+         FONTNAME)))
 
 ;; Scan a kst file and return two values which are the
 ;; raster width and raster height needed in a TV format font to contain that font.
-(defun read-kst-max-raster-width (filename &aux stream
-                                                raster-height (raster-width 0)
-                                                char-raster-width)
-  (setq stream (open (fs:file-parse-name filename nil t ':kst) '(:fixnum :in :byte-size 9.)))
-  ;; Discard KSTID.
-  (dotimes (i 4) (funcall stream ':tyi))
-  ;; Discard column-position-adjust
-  (funcall stream ':tyi)
-  ;; Discard baseline.
-  (funcall stream ':tyi)
-  ;; Remember font line height as raster height.
-  (setq raster-height (read-kst-halfword stream))
-  ;; Keep maxing raster widths of characters into raster-width
-  (setq raster-width 0)
-  (do () ((= (logand (read-kst-halfword stream) (read-kst-halfword stream)) -1))
-    ;; Ignore char's left kern.
-    (read-kst-halfword stream)
-    ;; Ignore its character code.
-    (read-kst-halfword stream)
-    ;; Max in its raster width
-    (setq char-raster-width (read-kst-halfword stream))
-    (setq raster-width (max raster-width char-raster-width))
-    ;; Ignore its character width.
-    (read-kst-halfword stream)
-    ;; Skip the bits of the character
-    (prog ((bytes (* raster-height (// (+ char-raster-width 7) 8))))
-          (setq bytes (* 4 (// (+ bytes 3) 4)))
-          (dotimes (i bytes)
-            (funcall stream ':tyi))))
-  (funcall stream ':close)
-  (prog () (return raster-width raster-height)))
+(DEFUN READ-KST-MAX-RASTER-WIDTH (FILENAME &AUX RASTER-HEIGHT (RASTER-WIDTH 0)
+                                                CHAR-RASTER-WIDTH)
+  (SETQ FILENAME (FS:MERGE-PATHNAME-DEFAULTS FILENAME (PATHNAME-DEFAULTS) "KST"))
+  (WITH-OPEN-FILE (STREAM FILENAME '(:FIXNUM :IN :BYTE-SIZE 9.))
+    ;; Discard KSTID.
+    (DOTIMES (I 4) (FUNCALL STREAM ':TYI))
+    ;; Discard column-position-adjust
+    (FUNCALL STREAM ':TYI)
+    ;; Discard baseline.
+    (FUNCALL STREAM ':TYI)
+    ;; Remember font line height as raster height.
+    (SETQ RASTER-HEIGHT (READ-KST-HALFWORD STREAM))
+    ;; Keep maxing raster widths of characters into raster-width
+    (SETQ RASTER-WIDTH 0)
+    (LOOP AS HEADER = (LOGIOR (ASH (READ-KST-HALFWORD STREAM) 18.) (READ-KST-HALFWORD STREAM))
+          UNTIL (= HEADER -1)
+          UNLESS (= HEADER 1)
+            DO (FERROR NIL "~O where character header expected; KST file misformatted" HEADER)
+      DO
+      ;; Ignore char's left kern.
+      (READ-KST-HALFWORD STREAM)
+      ;; Ignore its character code.
+      (READ-KST-HALFWORD STREAM)
+      ;; Max in its raster width
+      (SETQ CHAR-RASTER-WIDTH (READ-KST-HALFWORD STREAM))
+      (SETQ RASTER-WIDTH (MAX RASTER-WIDTH CHAR-RASTER-WIDTH))
+      ;; Ignore its character width.
+      (READ-KST-HALFWORD STREAM)
+      ;; Skip the bits of the character
+      (LET ((BYTES (* RASTER-HEIGHT (// (+ CHAR-RASTER-WIDTH 7) 8))))
+        (SETQ BYTES (* 4 (// (+ BYTES 3) 4)))
+        (DOTIMES (I BYTES)
+          (FUNCALL STREAM ':TYI)))))
+  (VALUES RASTER-WIDTH RASTER-HEIGHT))
 
 ;; Fetch the next 8-bit byte where stream is a 9-bit byte stream.
@@ -534 +665 @@
 ;; The car of our value is the next byte.
 ;; Save the value for the byte-list arg next time.
-(defun read-kst-bytes (stream byte-list byte-list-head)
-    (or (cdr byte-list)
-        ;; Exhausted the word - read another.
-        (let ((hwd1 (read-kst-halfword stream))
-              (hwd2 (read-kst-halfword stream)))
-             (setq byte-list byte-list-head)
-             ;; Turn it into 4 8-bit bytes in byte-list.
-             (rplaca byte-list (ldb 1210 hwd1))
-             (rplaca (cdr byte-list) (ldb 0210 hwd1))
-             (rplaca (cddr byte-list)
-                     (+ (lsh (ldb 0002 hwd1) 6)
-                        (ldb 1406 hwd2)))
-             (rplaca (cdddr byte-list) (ldb 0410 hwd2))
-             byte-list)))
+(DEFUN READ-KST-BYTES (STREAM BYTE-LIST BYTE-LIST-HEAD)
+  (OR (CDR BYTE-LIST)
+      ;; Exhausted the word - read another.
+      (LET ((HWD1 (READ-KST-HALFWORD STREAM))
+            (HWD2 (READ-KST-HALFWORD STREAM)))
+        (SETQ BYTE-LIST BYTE-LIST-HEAD)
+        ;; Turn it into 4 8-bit bytes in byte-list.
+        (RPLACA BYTE-LIST (LDB 1210 HWD1))
+        (RPLACA (CDR BYTE-LIST) (LDB 0210 HWD1))
+        (RPLACA (CDDR BYTE-LIST)
+                (+ (LSH (LDB 0002 HWD1) 6)
+                   (LDB 1406 HWD2)))
+        (RPLACA (CDDDR BYTE-LIST) (LDB 0410 HWD2))
+        BYTE-LIST)))
 
 ;; Read two 9-bit bytes from stream, make an 18-bit halfword,
 ;; and sign-extend it.
-(defun read-kst-halfword (stream &aux hwd)
-    (setq hwd (+ (* (funcall stream ':tyi) 1000)
-                 (funcall stream ':tyi)))
-    (cond ((bit-test hwd 400000)
-           (logior hwd -400000))
-          (t hwd)))
+(DEFUN READ-KST-HALFWORD (STREAM &AUX HWD)
+  (SETQ HWD (+ (* (FUNCALL STREAM ':TYI) 1000)
+               (FUNCALL STREAM ':TYI)))
+  (COND ((BIT-TEST HWD 400000)
+         (LOGIOR HWD -400000))
+        (T HWD)))
 
+;;; Given FONTNAME and FILENAME from FONTNAME &OPTIONAL FILENAME, canonicalize them.
+(DEFUN GET-OUTPUT-FILENAME-AND-FONTNAME (FONTNAME FILENAME FILE-TYPE)
+  (DECLARE (RETURN-LIST FONTNAME FILENAME))
+  (AND (STRINGP FONTNAME) (SETQ FONTNAME (INTERN (STRING-UPCASE FONTNAME) "FONTS")))
+  (OR FILENAME (SETQ FILENAME (STRING FONTNAME)))
+  (SETQ FILENAME (FS:MERGE-PATHNAME-DEFAULTS FILENAME (PATHNAME-DEFAULTS) FILE-TYPE))
+  (VALUES FONTNAME FILENAME))
+
+(DEFUN GET-OUTPUT-FILENAME-FROM-FONT-DESCRIPTOR (FONT-DESCRIPTOR FILENAME FILE-TYPE)
+  (OR FILENAME (SETQ FILENAME (STRING (FD-NAME FONT-DESCRIPTOR))))
+  (FS:MERGE-PATHNAME-DEFAULTS FILENAME (PATHNAME-DEFAULTS) FILE-TYPE))
+
 ;; It would be good to check for chars that are all zero and
 ;; flush them, and also to compute the actual needed raster width and use it.
-(defun write-font-into-kst (fontname &optional filename &aux stream font)
-  (and (stringp fontname) (setq fontname (intern fontname "FONTS")))
-  (setq filename (fs:file-parse-name filename nil t ':kst))
-  (setq font (symeval fontname))
-  (cond ((font-indexing-table font)
-         (let ((fd (font-name-font-descriptor fontname)))
-           (write-font-descriptor-into-kst fd filename)))
-        (t
-         (and (> (font-raster-height font)
-                 (font-char-height font))
-              (format t "Warning: font raster height exceeds line height"))
-         (setq stream (open filename '(:fixnum :out :byte-size 9.)))
-         ;; Write KSTID as 0.
-         (dotimes (i 4) (funcall stream ':tyo 0))
-         ;; Write column position adjust as 0.
-         (funcall stream ':tyo 0)
-         ;; Write baseline and height into second header word.
-         (funcall stream ':tyo (font-baseline font))
-         (write-kst-halfword stream (font-char-height font))
-         ;; Then write out all the characters.
-         (let (kern-table char-width-table chars-exist-table
-                          word-pos bit-pos byte-count byte
-                          char-raster-width byte-list byte-list-head)
-           (setq kern-table (font-left-kern-table font)
-                 char-width-table (font-char-width-table font))
-           (errset (setq chars-exist-table (font-chars-exist-table font)) nil)
-           (dotimes (char-code 200)
-             (and chars-exist-table
-                  (zerop (ar-1 chars-exist-table char-code))
-                  (go skip-char))
-             ;; Each char must start with a word containing a 1.
-             (write-kst-halfword stream 0)
-             (write-kst-halfword stream 1)
-             ;; left kern and char code fill the next word.
-             (write-kst-halfword stream
-                                 (or (and kern-table (ar-1 kern-table char-code)) 0))
-             (write-kst-halfword stream char-code)
-             ;; Raster width and char width are the next word.
-             (setq char-raster-width (max 1 (font-char-min-raster-width font char-code)))
-             (write-kst-halfword stream char-raster-width)
-             (write-kst-halfword stream 
-                                 (cond (char-width-table (or (ar-1 char-width-table char-code) 0))
-                                       (t (font-char-width font))))
-             ;; Write out the bits of the character
-             ;; Word-pos and bit-pos are used to point at a bit in the font.
-             (setq word-pos (* (font-words-per-char font) char-code))
-             (setq bit-pos 0 byte-count 0)
-             ;; Byte-list and its head are used to accumulate 4 bytes
-             ;; and then output them at once as a word.
-             ;; This is needed because the stream wants 9-bit bytes.
-             (setq byte-list-head (list nil nil nil nil))
-             (setq byte-list byte-list-head)
-             (dotimes (vpos (font-char-height font))
-               ;; Prepare to extract next row of char from font.
-               (and (> (+ bit-pos (font-raster-width font)) 32.)
-                    (setq word-pos (1+ word-pos) bit-pos 0))
-               (setq byte 0)
-               ;; Get the row a bit at a time and fill up 8-bit bytes.
-               ;; Output the bytes when full.  Output the excess at the end.
-               ;; Count the bytes output with byte-count
-               (dotimes (hpos char-raster-width)
-                 (cond ((and (= (\ hpos 8) 0) (not (zerop hpos)))
-                        (setq byte-count (1+ byte-count))
-                        (setq byte-list
-                              (write-kst-byte stream byte byte-list byte-list-head))
-                        (setq byte 0)))
-                 (or (
- vpos (font-raster-height font))
-                     (setq byte (+ byte (lsh (ar-1 font
-                                                   (+ (* 32. word-pos) hpos bit-pos))
-                                             (\ hpos 8))))))
-               (setq byte-count (1+ byte-count))
-               (setq byte-list (write-kst-byte stream byte byte-list byte-list-head))
-               (setq bit-pos (+ bit-pos (font-raster-width font))))
-             ;; Pad to a word boundary.
-             (do () ((zerop (\ byte-count 4)))
-               (setq byte-list (write-kst-byte stream 0 byte-list byte-list-head))
-               (setq byte-count (1+ byte-count)))
-             skip-char)
-           ;; Mark end of file with two -1 words.
-           (dotimes (i 8)
-             (funcall stream ':tyo -1)))
-         (close stream))))
+(DEFUN WRITE-FONT-INTO-KST (FONTNAME &OPTIONAL FILENAME &AUX FONT FONT-LENGTH)
+  (MULTIPLE-VALUE (FONTNAME FILENAME)
+    (GET-OUTPUT-FILENAME-AND-FONTNAME FONTNAME FILENAME "KST"))
+  (SETQ FONT (SYMEVAL FONTNAME))
+  (SETQ FONT-LENGTH (FONT-FILL-POINTER FONT))
+  (OR (AND FONT-LENGTH (
+ FONT-LENGTH 200))
+      (SETQ FONT-LENGTH 200))
+  (COND ((FONT-INDEXING-TABLE FONT)
+         (LET ((FD (FONT-NAME-FONT-DESCRIPTOR FONTNAME)))
+           (WRITE-FONT-DESCRIPTOR-INTO-KST FD FILENAME)))
+        (T
+         (AND (> (FONT-RASTER-HEIGHT FONT)
+                 (FONT-CHAR-HEIGHT FONT))
+              (FORMAT T "Warning: font raster height exceeds line height"))
+         (WITH-OPEN-FILE (STREAM FILENAME '(:FIXNUM :OUT :BYTE-SIZE 9.))
+           ;; Write KSTID as 0.
+           (DOTIMES (I 4) (FUNCALL STREAM ':TYO 0))
+           ;; Write column position adjust as 0.
+           (FUNCALL STREAM ':TYO 0)
+           ;; Write baseline and height into second header word.
+           (FUNCALL STREAM ':TYO (FONT-BASELINE FONT))
+           (WRITE-KST-HALFWORD STREAM (FONT-CHAR-HEIGHT FONT))
+           ;; Then write out all the characters.
+           (LET (KERN-TABLE CHAR-WIDTH-TABLE CHARS-EXIST-TABLE
+                 WORD-POS BIT-POS BYTE-COUNT BYTE
+                 CHAR-RASTER-WIDTH BYTE-LIST BYTE-LIST-HEAD)
+             (SETQ KERN-TABLE (FONT-LEFT-KERN-TABLE FONT)
+                   CHAR-WIDTH-TABLE (FONT-CHAR-WIDTH-TABLE FONT))
+             (ERRSET (SETQ CHARS-EXIST-TABLE (FONT-CHARS-EXIST-TABLE FONT)) NIL)
+             (DOTIMES (CHAR-CODE FONT-LENGTH)
+               (AND CHARS-EXIST-TABLE
+                    (ZEROP (AREF CHARS-EXIST-TABLE CHAR-CODE))
+                    (GO SKIP-CHAR))
+               ;; Each char must start with a word containing a 1.
+               (WRITE-KST-HALFWORD STREAM 0)
+               (WRITE-KST-HALFWORD STREAM 1)
+               ;; left kern and char code fill the next word.
+               (WRITE-KST-HALFWORD STREAM
+                                   (OR (AND KERN-TABLE (AREF KERN-TABLE CHAR-CODE)) 0))
+               (WRITE-KST-HALFWORD STREAM CHAR-CODE)
+               ;; Raster width and char width are the next word.
+               (SETQ CHAR-RASTER-WIDTH (MAX 1 (FONT-CHAR-MIN-RASTER-WIDTH FONT CHAR-CODE)))
+               (WRITE-KST-HALFWORD STREAM CHAR-RASTER-WIDTH)
+               (WRITE-KST-HALFWORD STREAM 
+                                   (COND (CHAR-WIDTH-TABLE
+                                          (OR (AREF CHAR-WIDTH-TABLE CHAR-CODE) 0))
+                                         (T (FONT-CHAR-WIDTH FONT))))
+               ;; Write out the bits of the character
+               ;; Word-pos and bit-pos are used to point at a bit in the font.
+               (SETQ WORD-POS (* (FONT-WORDS-PER-CHAR FONT) CHAR-CODE))
+               (SETQ BIT-POS 0 BYTE-COUNT 0)
+               ;; Byte-list and its head are used to accumulate 4 bytes
+               ;; and then output them at once as a word.
+               ;; This is needed because the stream wants 9-bit bytes.
+               (SETQ BYTE-LIST-HEAD (LIST NIL NIL NIL NIL))
+               (SETQ BYTE-LIST BYTE-LIST-HEAD)
+               (COND ((NOT (ZEROP CHAR-RASTER-WIDTH))
+                      (DOTIMES (VPOS (FONT-CHAR-HEIGHT FONT))
+                        ;; Prepare to extract next row of char from font.
+                        (AND (> (+ BIT-POS (FONT-RASTER-WIDTH FONT)) 32.)
+                             (SETQ WORD-POS (1+ WORD-POS) BIT-POS 0))
+                        (SETQ BYTE 0)
+                        ;; Get the row a bit at a time and fill up 8-bit bytes.
+                        ;; Output the bytes when full.  Output the excess at the end.
+                        ;; Count the bytes output with byte-count
+                        (DOTIMES (HPOS CHAR-RASTER-WIDTH)
+                          (COND ((AND (= (\ HPOS 8) 0) (NOT (ZEROP HPOS)))
+                                 (SETQ BYTE-COUNT (1+ BYTE-COUNT))
+                                 (SETQ BYTE-LIST
+                                       (WRITE-KST-BYTE STREAM BYTE BYTE-LIST BYTE-LIST-HEAD))
+                                 (SETQ BYTE 0)))
+                          (OR (
+ VPOS (FONT-RASTER-HEIGHT FONT))
+                              (SETQ BYTE (+ BYTE (LSH (AREF FONT
+                                                            (+ (* 32. WORD-POS) HPOS BIT-POS))
+                                                      (\ HPOS 8))))))
+                        (SETQ BYTE-LIST (WRITE-KST-BYTE STREAM BYTE BYTE-LIST BYTE-LIST-HEAD))
+                        (SETQ BYTE-COUNT (1+ BYTE-COUNT))
+                        (SETQ BIT-POS (+ BIT-POS (FONT-RASTER-WIDTH FONT))))
+                      ;; Pad to a word boundary.
+                      (DO () ((ZEROP (\ BYTE-COUNT 4)))
+                        (SETQ BYTE-LIST (WRITE-KST-BYTE STREAM 0 BYTE-LIST BYTE-LIST-HEAD))
+                        (SETQ BYTE-COUNT (1+ BYTE-COUNT)))))
+               SKIP-CHAR)
+             ;; Mark end of file with two -1 words.
+             (DOTIMES (I 8)
+               (FUNCALL STREAM ':TYO -1)))
+           (FUNCALL STREAM ':CLOSE)
+           (FUNCALL STREAM ':TRUENAME)))))
 
-(defun write-font-descriptor-into-kst (fd filename &aux stream)
-    (setq stream (open (fs:file-parse-name filename nil t ':kst)
-                       '(:fixnum :out :byte-size 9.)))
+(DEFUN WRITE-FONT-DESCRIPTOR-INTO-KST (FD &OPTIONAL FILENAME
+                                          &AUX (FONT-LENGTH (ARRAY-ACTIVE-LENGTH FD)))
+  (SETQ FILENAME (GET-OUTPUT-FILENAME-FROM-FONT-DESCRIPTOR FD FILENAME "KST"))
+  (WITH-OPEN-FILE (STREAM FILENAME '(:FIXNUM :OUT :BYTE-SIZE 9.))
     ;; Write KSTID as 0.
-    (dotimes (i 4) (funcall stream ':tyo 0))
+    (DOTIMES (I 4) (FUNCALL STREAM ':TYO 0))
     ;; Write column position adjust as 0.
-    (funcall stream ':tyo 0)
+    (FUNCALL STREAM ':TYO 0)
     ;; Write baseline and height into second header word.
-    (funcall stream ':tyo (fd-baseline fd))
-    (write-kst-halfword stream (fd-line-spacing fd))
+    (FUNCALL STREAM ':TYO (FD-BASELINE FD))
+    (WRITE-KST-HALFWORD STREAM (FD-LINE-SPACING FD))
     ;; Then write out all the characters.
-    (let (cd char-height byte-count byte byte-list byte-list-head)
-       (dotimes (char-code 200)
-          (cond ((and (setq cd (ar-1 fd char-code))
+    (LET (CD CHAR-HEIGHT BYTE-COUNT BYTE BYTE-LIST BYTE-LIST-HEAD)
+       (DOTIMES (CHAR-CODE FONT-LENGTH)
+          (COND ((AND (SETQ CD (AREF FD CHAR-CODE))
                       ;; Wide fonts without chars-exist-tables can have 0-width chars.
-                      (or (not (zerop (array-dimension-n 2 cd)))
-                          (not (zerop (cd-char-width cd)))))
+                      (OR (NOT (ZEROP (ARRAY-DIMENSION-N 2 CD)))
+                          (NOT (ZEROP (CD-CHAR-WIDTH CD)))))
             ;; Each char must start with a word containing a 1.
-            (write-kst-halfword stream 0)
-            (write-kst-halfword stream 1)
+            (WRITE-KST-HALFWORD STREAM 0)
+            (WRITE-KST-HALFWORD STREAM 1)
             ;; left kern and char code fill the next word.
-            (write-kst-halfword stream (cd-char-left-kern cd))
-            (write-kst-halfword stream char-code)
+            (WRITE-KST-HALFWORD STREAM (CD-CHAR-LEFT-KERN CD))
+            (WRITE-KST-HALFWORD STREAM CHAR-CODE)
             ;; Raster width and char width are the next word.
-            (write-kst-halfword stream (array-dimension-n 2 cd))
-            (write-kst-halfword stream (cd-char-width cd))
+            (WRITE-KST-HALFWORD STREAM (ARRAY-DIMENSION-N 2 CD))
+            (WRITE-KST-HALFWORD STREAM (CD-CHAR-WIDTH CD))
             ;; Write out the bits of the character
             ;; Byte-list and its head are used to accumulate 4 bytes
             ;; and then output them at once as a word.
             ;; This is needed because the stream wants 9-bit bytes.
-            (setq byte-list-head (list nil nil nil nil))
-            (setq byte-list byte-list-head)
-            (setq byte-count 0)
-            (setq char-height (array-dimension-n 1 cd))
-            (and (> char-height (fd-line-spacing fd))
-                 (ferror nil "Character ~C height exceeds font line height in KST file"
-                         char-code))
-            (dotimes (vpos (fd-line-spacing fd))
-               ;; Prepare to extract next row of char from font.
-               (setq byte 0)
-               ;; Get the row a bit at a time and fill up 8-bit bytes.
-               ;; Output the bytes when full.  Output the excess at the end.
-               ;; Count the bytes output with byte-count
-               (dotimes (hpos (array-dimension-n 2 cd))
-                   (cond ((and (= (\ hpos 8) 0) (not (zerop hpos)))
-                          (setq byte-count (1+ byte-count))
-                          (setq byte-list
-                                (write-kst-byte stream byte byte-list byte-list-head))
-                          (setq byte 0)))
-                   (or (
- vpos char-height)
-                       (setq byte (+ byte (lsh (ar-2 cd vpos hpos) (\ hpos 8))))))
-               (setq byte-count (1+ byte-count))
-               (setq byte-list (write-kst-byte stream byte byte-list byte-list-head)))
-            ;; Pad to a word boundary.
-            (do () ((zerop (\ byte-count 4)))
-               (setq byte-list (write-kst-byte stream 0 byte-list byte-list-head))
-               (setq byte-count (1+ byte-count))))))
+            (SETQ BYTE-LIST-HEAD (LIST NIL NIL NIL NIL))
+            (SETQ BYTE-LIST BYTE-LIST-HEAD)
+            (SETQ BYTE-COUNT 0)
+            (SETQ CHAR-HEIGHT (ARRAY-DIMENSION-N 1 CD))
+            (AND (> CHAR-HEIGHT (FD-LINE-SPACING FD))
+                 (FERROR NIL "Character ~C height exceeds font line height in KST file"
+                         CHAR-CODE))
+            (COND ((NOT (ZEROP (ARRAY-DIMENSION-N 2 CD)))
+                   (DOTIMES (VPOS (FD-LINE-SPACING FD))
+                     ;; Prepare to extract next row of char from font.
+                     (SETQ BYTE 0)
+                     ;; Get the row a bit at a time and fill up 8-bit bytes.
+                     ;; Output the bytes when full.  Output the excess at the end.
+                     ;; Count the bytes output with byte-count
+                     (DOTIMES (HPOS (ARRAY-DIMENSION-N 2 CD))
+                       (COND ((AND (= (\ HPOS 8) 0) (NOT (ZEROP HPOS)))
+                              (SETQ BYTE-COUNT (1+ BYTE-COUNT))
+                              (SETQ BYTE-LIST
+                                    (WRITE-KST-BYTE STREAM BYTE BYTE-LIST BYTE-LIST-HEAD))
+                              (SETQ BYTE 0)))
+                       (OR (
+ VPOS CHAR-HEIGHT)
+                           (SETQ BYTE (+ BYTE (LSH (AREF CD VPOS HPOS) (\ HPOS 8))))))
+                     (SETQ BYTE-LIST (WRITE-KST-BYTE STREAM BYTE BYTE-LIST BYTE-LIST-HEAD))
+                     (SETQ BYTE-COUNT (1+ BYTE-COUNT)))
+                   ;; Pad to a word boundary.
+                   (DO () ((ZEROP (\ BYTE-COUNT 4)))
+                     (SETQ BYTE-LIST (WRITE-KST-BYTE STREAM 0 BYTE-LIST BYTE-LIST-HEAD))
+                     (SETQ BYTE-COUNT (1+ BYTE-COUNT))))))))
        ;; Mark end of file with two -1 words.
-       (dotimes (i 8)
-            (funcall stream ':tyo -1)))
-    (close stream))
+       (DOTIMES (I 8)
+            (FUNCALL STREAM ':TYO -1)))
+    (FUNCALL STREAM ':CLOSE)
+    (FUNCALL STREAM ':TRUENAME)))
 
 ;; Write an 8-bit byte to the kst file.  We pack 4 bytes per word.
@@ -711 +864 @@
 ;; Byte-list-head should be a list of length 4 we can clobber.
 ;; byte-list should initially be the same thing;  we return a new value to set it to.
-(defun write-kst-byte (stream byte byte-list byte-list-head)
-    (rplaca byte-list byte)
-    (pop byte-list)
-    (cond ((null byte-list)
-           (setq byte-list byte-list-head)
-           (write-kst-halfword stream
-                  (+ (lsh (first byte-list) 10.)
-                     (lsh (second byte-list) 2.)
-                     (ldb 0602 (third byte-list))))
-           (write-kst-halfword stream
-                  (+ (lsh (ldb 0006 (third byte-list)) 12.)
-                     (lsh (fourth byte-list) 4)))))
-    byte-list)
-
-(defun write-kst-halfword (stream halfword)
-    (funcall stream ':tyo (ldb 1111 halfword))
-    (funcall stream ':tyo (ldb 0011 halfword)))
+(DEFUN WRITE-KST-BYTE (STREAM BYTE BYTE-LIST BYTE-LIST-HEAD)
+  (RPLACA BYTE-LIST BYTE)
+  (POP BYTE-LIST)
+  (COND ((NULL BYTE-LIST)
+         (SETQ BYTE-LIST BYTE-LIST-HEAD)
+         (WRITE-KST-HALFWORD STREAM
+                             (+ (LSH (FIRST BYTE-LIST) 10.)
+                                (LSH (SECOND BYTE-LIST) 2.)
+                                (LDB 0602 (THIRD BYTE-LIST))))
+         (WRITE-KST-HALFWORD STREAM
+                             (+ (LSH (LDB 0006 (THIRD BYTE-LIST)) 12.)
+                                (LSH (FOURTH BYTE-LIST) 4)))))
+  BYTE-LIST)
+
+(DEFUN WRITE-KST-HALFWORD (STREAM HALFWORD)
+  (FUNCALL STREAM ':TYO (LDB 1111 HALFWORD))
+  (FUNCALL STREAM ':TYO (LDB 0011 HALFWORD)))
 
 ;; Compute the smallest raster width needed to store the specified char
 ;; as defined by the specified font.
 ;; low-level means we are looking at one sub-character in a wide font.
-(defun font-char-min-raster-width (font char-code &optional low-level
-                                        &aux bit-pos word-pos tem
-                                        min-raster-width f-raster-width raster-height)
-    (cond ((and (not low-level)
-                (setq tem (font-indexing-table font)))
+(DEFUN FONT-CHAR-MIN-RASTER-WIDTH (FONT CHAR-CODE
+                                   &OPTIONAL LOW-LEVEL
+                                   &AUX BIT-POS WORD-POS TEM
+                                        MIN-RASTER-WIDTH F-RASTER-WIDTH RASTER-HEIGHT)
+    (COND ((AND (NOT LOW-LEVEL)
+                (SETQ TEM (FONT-INDEXING-TABLE FONT)))
            ;; If it's a wide font, go by the number of vertical stripes,
            ;; but also see how wide the rightmost stripe really needs to be.
-           (max 0
-                (+ (* 32. (- (ar-1 tem (1+ char-code)) (ar-1 tem char-code)))
-                   -32.
-                   (font-char-min-raster-width font (1- (ar-1 tem (1+ char-code))) t))))
-          (t (setq word-pos (* char-code (font-words-per-char font))
-                   bit-pos 0
-                   min-raster-width 0
-                   f-raster-width (font-raster-width font)
-                   raster-height (font-raster-height font))
-             (dotimes (vpos raster-height)
-                 (and (> (+ bit-pos f-raster-width) 32.)
-                      (setq bit-pos 0 word-pos (1+ word-pos)))
-                 (do ((hpos 0 (1+ hpos)) (index (+ bit-pos (lsh word-pos 5)) (1+ index)))
-                     ((= hpos f-raster-width))
-                    (or (zerop (ar-1 font index))
-                        (setq min-raster-width (max (1+ hpos) min-raster-width))))
-                 (setq bit-pos (+ f-raster-width bit-pos)))
-             min-raster-width)))
+           (LET ((START-IDX (AREF TEM CHAR-CODE))
+                 (END-IDX (AREF TEM (1+ CHAR-CODE))))
+             (IF (= START-IDX END-IDX)
+                 0
+                 (MAX 0
+                      (+ (* 32. (- END-IDX START-IDX))
+                         -32.
+                         (FONT-CHAR-MIN-RASTER-WIDTH FONT (1- END-IDX) T))))))
+          (T (SETQ WORD-POS (* CHAR-CODE (FONT-WORDS-PER-CHAR FONT))
+                   BIT-POS 0
+                   MIN-RASTER-WIDTH 0
+                   F-RASTER-WIDTH (FONT-RASTER-WIDTH FONT)
+                   RASTER-HEIGHT (FONT-RASTER-HEIGHT FONT))
+             (DOTIMES (VPOS RASTER-HEIGHT)
+                 (AND (> (+ BIT-POS F-RASTER-WIDTH) 32.)
+                      (SETQ BIT-POS 0 WORD-POS (1+ WORD-POS)))
+                 (DO ((HPOS 0 (1+ HPOS)) (INDEX (+ BIT-POS (LSH WORD-POS 5)) (1+ INDEX)))
+                     ((= HPOS F-RASTER-WIDTH))
+                    (OR (ZEROP (AREF FONT INDEX))
+                        (SETQ MIN-RASTER-WIDTH (MAX (1+ HPOS) MIN-RASTER-WIDTH))))
+                 (SETQ BIT-POS (+ F-RASTER-WIDTH BIT-POS)))
+             MIN-RASTER-WIDTH)))
 
 ;; ALTO .AL format
+;;;??? Not yet converted to load more than 200 chars into a font.
+
 ;; Load an ALTO font file into a font, the easy way, via a font descriptor
 (DEFUN READ-AL-INTO-FONT (FILENAME &OPTIONAL FONTNAME)
-  (SETQ FILENAME (FS:FILE-PARSE-NAME FILENAME NIL T ':AL))
-  (OR FONTNAME (SETQ FONTNAME (FUNCALL FILENAME ':NAME)))
-  (AND (STRINGP FONTNAME) (SETQ FONTNAME (INTERN FONTNAME "FONTS")))
+  (MULTIPLE-VALUE (FILENAME FONTNAME)
+    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AL"))
   (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME
                                      (READ-AL-INTO-FONT-DESCRIPTOR FILENAME FONTNAME))
-  (SYMEVAL FONTNAME))
+  FONTNAME)
 
 ;; Load an ALTO font file into a font descriptor
 (DEFUN READ-AL-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME
-                                              &AUX FD STREAM ARRAY LINE-HEIGHT)
-  (SETQ FILENAME (FS:FILE-PARSE-NAME FILENAME NIL T ':AL))
-  (OR FONTNAME (SETQ FONTNAME (FUNCALL FILENAME ':NAME)))
-  (AND (STRINGP FONTNAME) (SETQ FONTNAME (INTERN FONTNAME "FONTS")))
+                                     &AUX FD ARRAY LINE-HEIGHT PROPORTIONAL MAX-WIDTH)
+  (MULTIPLE-VALUE (FILENAME FONTNAME)
+    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AL"))
   (SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME))
   (SETF (FD-NAME FD) FONTNAME)
-  (SETQ STREAM (OPEN FILENAME '(:IN :FIXNUM)))
-  (UNWIND-PROTECT
-   (PROGN
+  (WITH-OPEN-FILE (STREAM FILENAME '(:IN :FIXNUM))
     (SETQ LINE-HEIGHT (FUNCALL STREAM ':TYI))
     (SETF (FD-LINE-SPACING FD) LINE-HEIGHT)
     (SETF (FD-BLINKER-HEIGHT FD) LINE-HEIGHT)
     (LET ((BASELINE-AND-MAX-WIDTH (FUNCALL STREAM ':TYI)))
+      (SETQ PROPORTIONAL (LDB-TEST 1701 BASELINE-AND-MAX-WIDTH))
       (SETF (FD-BASELINE FD) (LDB 1007 BASELINE-AND-MAX-WIDTH))
-      (SETF (FD-SPACE-WIDTH FD) (LDB 0010 BASELINE-AND-MAX-WIDTH)))
-    (SETQ ARRAY (MAKE-ARRAY NIL 'ART-16B 1000. NIL '(0)))
+      (SETF (FD-SPACE-WIDTH FD) (SETQ MAX-WIDTH (LDB 0010 BASELINE-AND-MAX-WIDTH))))
+    (SETQ ARRAY (MAKE-ARRAY 1000. ':TYPE 'ART-16B ':LEADER-LIST '(0)))
     (DO CH (FUNCALL STREAM ':TYI) (FUNCALL STREAM ':TYI) (NULL CH)
       (ARRAY-PUSH-EXTEND ARRAY CH)))
-   (FUNCALL STREAM ':CLOSE))
   (DO ((CH 0 (1+ CH))
        (CD)
        (CHAR-WIDTH))
       ((
- CH 200))
+ CH 200))       ;Alto font could have 400 characters, our fonts don't yet
     (SETQ CHAR-WIDTH 0)
     (DO ((IDX CH)
@@ -803 +959 @@
           (SETQ CHAR-WIDTH (+ CHAR-WIDTH 16.)
                 IDX XW)
-          (SETQ CHAR-WIDTH (+ CHAR-WIDTH XW))
-          (RETURN)))
-    (SETQ CD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (NIL ART-1B (LIST LINE-HEIGHT CHAR-WIDTH))))
+          (RETURN (SETQ CHAR-WIDTH (+ CHAR-WIDTH XW)))))
+    (SETQ CD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (:TYPE ART-1B
+                                               :LENGTH (LIST LINE-HEIGHT CHAR-WIDTH))))
     (SETF (CD-CHAR-WIDTH CD) CHAR-WIDTH)
     (AND (= CH #\SP) (SETF (FD-SPACE-WIDTH FD) CHAR-WIDTH))
@@ -825 +981 @@
       ((= I IDX))
     (DO ((BITS (AREF ARRAY I) (LSH BITS 1))
-         (X XOFF (1+ X)))
-        ((ZEROP BITS))
+         (X XOFF (1+ X))
+         (CW (CD-CHAR-WIDTH CD)))
+        ((OR (ZEROP BITS) (
+ X CW)))                ;Can be garbage to right of raster
       (AND (BIT-TEST 100000 BITS)
            (ASET 1 CD Y X))))
   (OR (BIT-TEST 1 XW)
       (READ-AL-INTO-FONT-DESCRIPTOR-1 CD ARRAY (// XW 2) (+ XOFF 16.))))
+
+(DEFUN WRITE-FONT-INTO-AL (FONTNAME &OPTIONAL FILENAME)
+  (MULTIPLE-VALUE (FONTNAME FILENAME)
+    (GET-OUTPUT-FILENAME-AND-FONTNAME FONTNAME FILENAME "AL"))
+  (LET ((FD (FONT-NAME-FONT-DESCRIPTOR FONTNAME)))
+    (WRITE-FONT-DESCRIPTOR-INTO-AL FD FILENAME)))
+
+;I don't think this does the desired thing for variable-width ("proportional") fonts
+(DEFUN WRITE-FONT-DESCRIPTOR-INTO-AL (FD &OPTIONAL FILENAME &AUX ARRAY CARRAY LINE-HEIGHT)
+  (SETQ FILENAME (GET-OUTPUT-FILENAME-FROM-FONT-DESCRIPTOR FD FILENAME "AL"))
+  (WITH-OPEN-FILE (STREAM FILENAME '(:OUT :FIXNUM))
+    (FUNCALL STREAM ':TYO (SETQ LINE-HEIGHT (FD-LINE-SPACING FD)))
+    (FUNCALL STREAM ':TYO (DPB (FD-BASELINE FD) 1007 (FD-SPACE-WIDTH FD)))
+    (SETQ ARRAY (MAKE-ARRAY 1000. ':TYPE 'ART-16B ':LEADER-LIST '(0))   ;Data array
+          CARRAY (MAKE-ARRAY 400 ':TYPE 'ART-16B ':LEADER-LIST '(400))) ;Non self-rel chars
+    ;; Store dummy
+    (ARRAY-PUSH-EXTEND ARRAY 1)
+    (ARRAY-PUSH-EXTEND ARRAY 0)
+    (LOOP FOR CH FROM 0 BELOW 200
+          AS CD = (AREF FD CH)
+          AS CHAR-WIDTH = (CD-CHAR-WIDTH CD)
+          DO (LOOP WITH CH = CH WITH (XW HD-XH)
+                   FOR XOFF FROM 0 BY 16. BELOW CHAR-WIDTH
+                   DO (SETQ HD-XH (WRITE-AL-COLUMN CD XOFF ARRAY))
+                      (ASET (ARRAY-LEADER ARRAY 0) CARRAY CH)
+                      (SETQ XW (IF (> (- CHAR-WIDTH XOFF) 16.)
+                                   (* (SETQ CH (PROG1 (ARRAY-LEADER CARRAY 0)
+                                                      (ARRAY-PUSH-EXTEND CARRAY 0)))
+                                      2)
+                                   (1+ (* (- CHAR-WIDTH XOFF) 2))))
+                      (ARRAY-PUSH-EXTEND ARRAY XW)
+                      (ARRAY-PUSH-EXTEND ARRAY HD-XH)))
+    (LOOP FOR I FROM 0 BELOW (ARRAY-ACTIVE-LENGTH CARRAY)       ;Make self-relative
+          DO (ASET (- (+ (AREF CARRAY I) (ARRAY-ACTIVE-LENGTH CARRAY)) I)
+                   CARRAY I))
+    (FUNCALL STREAM ':STRING-OUT CARRAY)
+    (FUNCALL STREAM ':STRING-OUT ARRAY)
+    (FUNCALL STREAM ':CLOSE)
+    (FUNCALL STREAM ':TRUENAME)))
+
+(DEFUN WRITE-AL-COLUMN-ROW (CD XOFF Y)
+  (LOOP WITH STUFF = 0
+        FOR X FROM (+ XOFF (CD-CHAR-LEFT-KERN CD)) BELOW (ARRAY-DIMENSION-N 2 CD)
+        AS MASK = 100000 THEN (LSH MASK -1) UNTIL (ZEROP MASK)
+        WHEN (AND (NOT (MINUSP X)) (NOT (ZEROP (AREF CD Y X))))
+          DO (SETQ STUFF (LOGIOR STUFF MASK))
+        FINALLY (RETURN STUFF)))
+
+(DEFUN WRITE-AL-COLUMN (CD XOFF ARRAY &AUX (HD 0) (XC 0))
+  (LOOP FOR Y FROM 0 TO (LOOP FOR Y FROM (1- (ARRAY-DIMENSION-N 1 CD)) DOWNTO 0
+                              WHILE (ZEROP (WRITE-AL-COLUMN-ROW CD XOFF Y))
+                              FINALLY (RETURN Y))
+        AS ROW = (WRITE-AL-COLUMN-ROW CD XOFF Y)
+        DO (IF (AND (ZEROP ROW) (ZEROP XC))
+               (SETQ HD (1+ HD))
+               (ARRAY-PUSH-EXTEND ARRAY ROW)
+               (SETQ XC (1+ XC))))
+  (DPB HD 1010 XC))
 
+;; ALTO .KS format
+;; Load a kerned-strike file into a font
+(DEFUN READ-KS-INTO-FONT (FILENAME &OPTIONAL FONTNAME)
+  (MULTIPLE-VALUE (FILENAME FONTNAME)
+    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "KS"))
+  (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME
+        (READ-KS-INTO-FONT-DESCRIPTOR FILENAME FONTNAME))
+  FONTNAME)
+
+;; Load a kerned-strike font file into a font descriptor
+(DEFUN READ-KS-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME
+                                              &AUX FD LINE-HEIGHT MAX-WIDTH WD FIXED-WIDTH
+                                              MIN-CHAR MAX-CHAR STRIKE-NWDS FBBOX
+                                              ASCENT DESCENT WORDS-PER-RASTER
+                                              BITMAP BITMAP16 INDEX)
+  (MULTIPLE-VALUE (FILENAME FONTNAME)
+    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "KS"))
+  (SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME))
+  (SETF (FD-NAME FD) FONTNAME)
+  (WITH-OPEN-FILE (STREAM FILENAME '(:IN :FIXNUM))
+    (SETQ WD (FUNCALL STREAM ':TYI))
+    (OR (BIT-TEST 100000 WD) (FERROR NIL "Not /"new format/""))
+    (AND (BIT-TEST 40000 WD) (FERROR NIL "StrikeIndex format not understood"))
+    (SETQ FIXED-WIDTH (BIT-TEST 20000 WD))
+    (OR (BIT-TEST 10000 WD) (FERROR NIL "PlainStrike format not understood"))
+    (SETQ MIN-CHAR (FUNCALL STREAM ':TYI) MAX-CHAR (FUNCALL STREAM ':TYI))
+    (SETQ MAX-WIDTH (FUNCALL STREAM ':TYI))
+    (SETQ FBBOX (FUNCALL STREAM ':TYI))         ;Font bounding-box X-offset
+    (IF (BIT-TEST 100000 FBBOX) (SETQ FBBOX (- FBBOX 200000)))  ;signed
+    (DOTIMES (I 3) (FUNCALL STREAM ':TYI))      ;Ignore rest of font bounding box
+    (SETQ STRIKE-NWDS (FUNCALL STREAM ':TYI)
+          ASCENT (FUNCALL STREAM ':TYI)
+          DESCENT (FUNCALL STREAM ':TYI))
+    (SETQ LINE-HEIGHT (+ ASCENT DESCENT))
+    (FUNCALL STREAM ':TYI)                      ;Ignore xoffset
+    (SETQ WORDS-PER-RASTER (FUNCALL STREAM ':TYI))
+    (SETF (FD-LINE-SPACING FD) LINE-HEIGHT)
+    (SETF (FD-BLINKER-HEIGHT FD) LINE-HEIGHT)
+    (SETF (FD-BASELINE FD) ASCENT)
+    (SETF (FD-SPACE-WIDTH FD) MAX-WIDTH)
+    ;; Now copy the bitmap (the goddamn words are bit-reversed!)
+    (SETQ BITMAP16 (MAKE-ARRAY (LIST WORDS-PER-RASTER LINE-HEIGHT) ':TYPE 'ART-16B)
+          BITMAP (MAKE-ARRAY (LIST (* WORDS-PER-RASTER 16.) LINE-HEIGHT)
+                             ':TYPE 'ART-1B ':DISPLACED-TO BITMAP16))
+    (DOTIMES (Y LINE-HEIGHT)
+      (DOTIMES (X WORDS-PER-RASTER)
+        (ASET (FUNCALL STREAM ':TYI) BITMAP16 (- WORDS-PER-RASTER X 1) Y)))
+    ;; Copy the index segment
+    (SETQ INDEX (MAKE-ARRAY (+ (- MAX-CHAR MIN-CHAR) 3) ':TYPE 'ART-16B))
+    (DOTIMES (I (ARRAY-LENGTH INDEX))
+      (ASET (FUNCALL STREAM ':TYI) INDEX I))
+    ;; Read the width table and make the characters
+    (LOOP FOR CH FROM MIN-CHAR TO (MIN (1+ MAX-CHAR) 177) WITH CD
+          AS XLEFT = (AREF INDEX (- CH MIN-CHAR))
+          AS XRIGHT = (AREF INDEX (1+ (- CH MIN-CHAR)))
+          AS WDE = (FUNCALL STREAM ':TYI)
+          UNLESS (= WDE 177777)         ;Nonexistent character
+          DO (SETQ CD (MAKE-CHAR-DESCRIPTOR
+                        MAKE-ARRAY (:TYPE ART-1B
+                                    :LENGTH (LIST LINE-HEIGHT (- XRIGHT XLEFT)))))
+             (SETF (CD-CHAR-WIDTH CD) (LDB 0010 WDE))
+             (AND (= CH #\SP) (SETF (FD-SPACE-WIDTH FD) (CD-CHAR-WIDTH CD)))
+             (SETF (CD-CHAR-LEFT-KERN CD) (- (+ (LDB 1010 WDE) FBBOX)))
+             (ASET CD FD CH)
+             (LOOP FOR Y FROM 0 BELOW LINE-HEIGHT DO
+               (LOOP FOR X FROM 0 BELOW (- XRIGHT XLEFT)
+                     AS BMX DOWNFROM (- (ARRAY-DIMENSION-N 1 BITMAP) XLEFT 1)
+                     DO (ASET (AREF BITMAP BMX Y) CD Y X))))
+  (SETF (FD-FILL-POINTER FD) 200)
+  ;; Set width of blinker and space fields from the space character.
+  (SETF (FD-BLINKER-WIDTH FD) (FD-SPACE-WIDTH FD))
+  FD))
+
+;;; Some useful font munging functions
 (DEFUN THICKEN-FONT-DESCRIPTOR (FD &OPTIONAL NEW-NAME &AUX LEN NFD)
   (OR NEW-NAME (SETQ NEW-NAME (INTERN (STRING-APPEND (FD-NAME FD) #/B) "FONTS")))
-  (SETQ LEN (ARRAY-LENGTH FD)
-        NFD (MAKE-FONT-DESCRIPTOR MAKE-ARRAY (NIL ART-Q LEN)
+  (SETQ LEN (ARRAY-ACTIVE-LENGTH FD)
+        NFD (MAKE-FONT-DESCRIPTOR MAKE-ARRAY (:TYPE 'ART-Q :LENGTH LEN)
+                                  FD-FILL-POINTER (FD-FILL-POINTER FD)
                                   FD-NAME NEW-NAME
                                   FD-LINE-SPACING (FD-LINE-SPACING FD)
@@ -849 +1140 @@
          (LET ((WIDTH (ARRAY-DIMENSION-N 2 CD))
                (HEIGHT (ARRAY-DIMENSION-N 1 CD)))
-           (SETQ NCD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (NIL ART-4B (LIST HEIGHT (1+ WIDTH)))
+           (SETQ NCD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (:TYPE 'ART-4B
+                                                       :LENGTH (LIST HEIGHT (1+ WIDTH)))
                                            CD-CHAR-WIDTH (1+ (CD-CHAR-WIDTH CD))
                                            CD-CHAR-LEFT-KERN (CD-CHAR-LEFT-KERN CD)))
@@ -859 +1151 @@
   NFD)
 
-(DEFUN THICKEN-FONT (FONT-SYMBOL &AUX FD NFD NFS NFNT)
-  (SETQ FD (FONT-NAME-FONT-DESCRIPTOR FONT-SYMBOL))
-  (SETQ NFD (THICKEN-FONT-DESCRIPTOR FD))
-  (SETQ NFS (FD-NAME NFD))
-  (SETQ NFNT (FONT-DESCRIPTOR-INTO-FONT NFD))
-  (SET NFS NFNT)
-  (PUTPROP NFS NFD 'FONT-DESCRIPTOR)
-  (PUTPROP NFS NFNT 'FONT-DESCRIBED)
+(DEFUN THICKEN-FONT (FONT-SYMBOL &AUX FD NFD NFS)
+  (SETQ FD (FONT-NAME-FONT-DESCRIPTOR FONT-SYMBOL)
+        NFD (THICKEN-FONT-DESCRIPTOR FD)
+        NFS (FD-NAME NFD))
+  (FONT-NAME-SET-FONT-AND-DESCRIPTOR NFS NFD)
   NFS)
+
+(DEFUN UNTHICKEN-FONT-DESCRIPTOR (FD NEW-NAME &AUX LEN NFD)
+  (SETQ LEN (ARRAY-ACTIVE-LENGTH FD)
+        NFD (MAKE-FONT-DESCRIPTOR MAKE-ARRAY (:TYPE 'ART-Q :LENGTH LEN)
+                                  FD-FILL-POINTER (FD-FILL-POINTER FD)
+                                  FD-NAME NEW-NAME
+                                  FD-LINE-SPACING (FD-LINE-SPACING FD)
+                                  FD-BASELINE (FD-BASELINE FD)
+                                  FD-BLINKER-HEIGHT (FD-BLINKER-HEIGHT FD)
+                                  FD-BLINKER-WIDTH (FD-BLINKER-WIDTH FD)
+                                  FD-SPACE-WIDTH (FD-SPACE-WIDTH FD)))
+  (DO ((I 0 (1+ I))
+       (CD) (NCD))
+      ((
+ I LEN))
+    (AND (SETQ CD (AREF FD I))
+         (LET ((WIDTH (ARRAY-DIMENSION-N 2 CD))
+               (HEIGHT (ARRAY-DIMENSION-N 1 CD)))
+           (SETQ NCD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (:TYPE 'ART-4B
+                                                       :LENGTH (LIST HEIGHT WIDTH))
+                                           CD-CHAR-WIDTH (CD-CHAR-WIDTH CD)
+                                           CD-CHAR-LEFT-KERN (CD-CHAR-LEFT-KERN CD)))
+           (COPY-ARRAY-CONTENTS CD NCD)
+           ;110  100
+           (DOTIMES (J HEIGHT)
+             (LOOP FOR I FROM (1- WIDTH) ABOVE 0
+                   AS RIGHT = 0 THEN THIS
+                   AS THIS FIRST (AREF CD J I) THEN LEFT
+                   AS LEFT = (AREF CD J (1- I))
+                   WHEN (AND (= LEFT 1) (= THIS 1) (= RIGHT 0))
+                     DO (ASET 0 NCD J I)))
+           (ASET NCD NFD I))))
+  NFD)
+
+(DEFUN UNTHICKEN-FONT (FONT-SYMBOL NFS &AUX FD NFD)
+  (SETQ FD (FONT-NAME-FONT-DESCRIPTOR FONT-SYMBOL)
+        NFD (UNTHICKEN-FONT-DESCRIPTOR FD NFS))
+  (FONT-NAME-SET-FONT-AND-DESCRIPTOR NFS NFD)
+  NFS)
+
+(DEFUN ROTATE-FONT-DESCRIPTOR (FD &AUX LENGTH NFD)
+  (SETQ LENGTH (ARRAY-ACTIVE-LENGTH FD)
+        NFD (MAKE-FONT-DESCRIPTOR :MAKE-ARRAY (:LENGTH LENGTH)
+                                  FD-FILL-POINTER (FD-FILL-POINTER FD)
+                                  FD-NAME (INTERN (STRING-APPEND (FD-NAME FD) #/R) "FONTS")
+                                  FD-BASELINE (FD-SPACE-WIDTH FD)
+                                  FD-LINE-SPACING (FD-SPACE-WIDTH FD)
+                                  FD-BLINKER-HEIGHT (FD-BLINKER-WIDTH FD)
+                                  FD-BLINKER-WIDTH (FD-BLINKER-HEIGHT FD)
+                                  FD-SPACE-WIDTH (FD-LINE-SPACING FD)
+                                  FD-ROTATION 90.))
+  (LOOP FOR CH FROM 0 BELOW LENGTH
+        AS CD = (AREF FD CH)
+        WHEN CD
+        DO (ASET (ROTATE-CHAR-DESCRIPTOR CD) NFD CH))
+  NFD)
+
+(DEFUN ROTATE-CHAR-DESCRIPTOR (CD)
+  (LET* ((HEI (ARRAY-DIMENSION-N 1 CD))
+         (WID (ARRAY-DIMENSION-N 2 CD))
+         (NCD (MAKE-CHAR-DESCRIPTOR :MAKE-ARRAY (:LENGTH (LIST WID HEI)
+                                                         :TYPE (ARRAY-TYPE CD))
+                                    CD-CHAR-LEFT-KERN 0
+                                    CD-CHAR-WIDTH HEI)))
+    (LOOP FOR X FROM 0 BELOW WID
+          DO (LOOP FOR Y FROM 0 BELOW HEI
+                   DO (ASET (AREF CD Y X) NCD (- WID X 1) Y)))
+    NCD))
+
+(DEFUN ROTATE-FONT (FONT-SYMBOL &AUX FD NFD NFS)
+  (SETQ FD (FONT-NAME-FONT-DESCRIPTOR FONT-SYMBOL)
+        NFD (ROTATE-FONT-DESCRIPTOR FD)
+        NFS (FD-NAME NFD))
+  (FONT-NAME-SET-FONT-AND-DESCRIPTOR NFS NFD)
+  NFS)
+
+(DEFMACRO SIGN-EXTEND (16BIT-WORD)
+  `(LET ((WORD ,16BIT-WORD))
+     (IF (
+ WORD 100000)
+         (- WORD 200000)
+         WORD)))
+
+(DEFMACRO HIGH-BYTE (WORD)
+  `(LSH ,WORD -8))
+
+(DEFMACRO LOW-BYTE (WORD)
+  `(BOOLE 1 377 ,WORD))
+
+;Get next 16-bit word from input-file
+(DEFUN NEXT-WORD ()
+  (DECLARE (SPECIAL INPUT-FILE))
+  (FUNCALL INPUT-FILE ':TYI "Unexpected EOF on AC file"))
+
+;Read in an AC file as a Lisp machine font.
+(DEFUN READ-AC-INTO-FONT (FILENAME &OPTIONAL FONTNAME)
+  (MULTIPLE-VALUE (FILENAME FONTNAME)
+    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AC"))
+  (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME
+                                     (READ-AC-INTO-FONT-DESCRIPTOR FILENAME FONTNAME))
+  FONTNAME)
+
+(DEFUN READ-AC-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME
+                                              &AUX FAMILY-NAME FACE-CODE POINT-SIZE)
+  (DECLARE (SPECIAL INPUT-FILE))
+  (MULTIPLE-VALUE (FILENAME FONTNAME)
+    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AC"))
+  (WITH-OPEN-FILE (INPUT-FILE FILENAME '(:READ :FIXNUM))
+    (SETF (VALUES FAMILY-NAME FACE-CODE POINT-SIZE)
+          (PRESS:DECODE-FONT-NAME (STRING FONTNAME)))
+    (LET ((CODE-ALIST NIL)
+          (SEGMENT-DATA NIL)
+          FAMILY-CODE TEM SEGMENT
+          FD
+          (WD 0))
+      (SETQ WD (NEXT-WORD))
+      ;; Read IXN entries (type 1)
+      (DO () ((NOT (= (LSH WD -12.) 1)))
+        (LET ((CODE (NEXT-WORD))
+              (NAME (PRESS:BCPL-STRING 20. INPUT-FILE)))
+          (PUSH (CONS CODE NAME) CODE-ALIST))
+        (SETQ WD (NEXT-WORD)))
+      ;; Find out the code number for the font family to be used,
+      ;; either the specified one or the only one.
+      (COND (FAMILY-NAME
+             (OR (SETQ FAMILY-CODE (CAR (RASSOC FAMILY-NAME CODE-ALIST)))
+                 (FERROR NIL "Font family ~A not present in AC file" FAMILY-NAME)))
+            ((CDR CODE-ALIST)
+             (FERROR NIL "Font dictionary ~A: font family not specified" FILENAME))
+            (T (SETQ FAMILY-CODE (CAAR CODE-ALIST))))
+      ;; Read Index Entries (type 3) for AC segments.
+      (DO () ((NOT (= (LSH WD -12.) 3)))
+        (SETQ WD (NEXT-WORD))                   ;family,,face
+        (SETQ TEM
+              (LIST (HIGH-BYTE WD)              ;Family code number.
+                    (PRESS:DECODE-FACE (LOW-BYTE WD))   ;Face name
+                    (PROGN (SETQ WD (NEXT-WORD))        ;bc,,ec
+                           (HIGH-BYTE WD))      ;First code
+                    (LOW-BYTE WD)               ;Last code
+                    (NEXT-WORD)                 ;Size
+                    (NEXT-WORD)                 ;Rotation
+                    (+ (LSH (NEXT-WORD) 16.) (NEXT-WORD))       ;Segment SA
+                    (+ (LSH (NEXT-WORD) 16.) (NEXT-WORD))       ;Segment Len
+                    (NEXT-WORD)                 ;horiz resolution
+                    (NEXT-WORD)))               ;vert resolution
+        (AND (= (CAR TEM) FAMILY-CODE) (PUSH TEM SEGMENT-DATA))
+        (SETQ WD (NEXT-WORD)))
+      ;; Now should have type-0 entry (end of index)
+      (SELECTQ (LSH WD -12.)
+        (0 )
+        (5 (FERROR NIL "There are OrbitChars segments in this file -- I don't grok them"))
+        (OTHERWISE
+          (FERROR NIL "~O - Bullshit in file where type 0 IX expected" WD)))
+      ;; Now either there should be only one segment or the face code and size
+      ;; should have been specified.
+      (COND ((AND POINT-SIZE FACE-CODE)
+             (DOLIST (SEG SEGMENT-DATA)
+               (AND (STRING-EQUAL (CADR SEG) FACE-CODE)
+                    (= (// (+ 1270. (* (FIFTH SEG) 72.)) 2540.) POINT-SIZE)
+                    (RETURN (SETQ SEGMENT SEG))))
+             (OR SEGMENT (FERROR NIL "Font ~A not found in AC file" FONTNAME)))
+            ((CDR SEGMENT-DATA)
+             (FERROR "Font dictionary ~A: point size or face code not specified" FILENAME))
+            (T (SETQ SEGMENT (CAR SEGMENT-DATA)
+                     POINT-SIZE (// (+ 1270. (* (FIFTH SEGMENT) 72.)) 2540.))))
+      (FUNCALL INPUT-FILE ':SET-POINTER (SEVENTH SEGMENT))
+      (LET ((BC (THIRD SEGMENT))
+            (EC (FOURTH SEGMENT))
+            (BASELINE 0)
+            (XWIDTHS (MAKE-ARRAY 400))
+            (YWIDTHS (MAKE-ARRAY 400))
+            (BOX-X-OFFSET (MAKE-ARRAY 400))
+            (BOX-Y-OFFSET (MAKE-ARRAY 400))
+            (BOX-X-SIZE (MAKE-ARRAY 400))
+            (BOX-Y-SIZE (MAKE-ARRAY 400))
+            (CHAR-DATA-POSITION (MAKE-ARRAY 400))
+            LINE-HEIGHT)
+        ;; read in the widths info from the segment.
+        (DO ((I BC (1+ I))) ((> I EC))
+          (ASET (+ (SIGN-EXTEND (NEXT-WORD)) (// (NEXT-WORD) 65536.0))
+                XWIDTHS I)
+          (ASET (+ (SIGN-EXTEND (NEXT-WORD)) (// (NEXT-WORD) 65536.0))
+                YWIDTHS I)
+          (ASET (SIGN-EXTEND (NEXT-WORD)) BOX-X-OFFSET I)
+          (ASET (SIGN-EXTEND (NEXT-WORD)) BOX-Y-OFFSET I)
+          (ASET (SIGN-EXTEND (NEXT-WORD)) BOX-X-SIZE I)
+          (ASET (SIGN-EXTEND (NEXT-WORD)) BOX-Y-SIZE I))
+        ;; Read relative pointers to character data beginnings
+        ;; and convert them to absolute pointers within the file.
+        (DO ((I BC (1+ I))
+             (STARTING-POSITION (FUNCALL INPUT-FILE ':READ-POINTER)))
+            ((> I EC))
+          (SETF (AREF CHAR-DATA-POSITION I)
+                (+ (LSH (NEXT-WORD) 32.)
+                   (NEXT-WORD)
+                   STARTING-POSITION)))
+        (SETQ FONTNAME (STRING-APPEND (CDR (ASSQ FAMILY-CODE CODE-ALIST))
+                                      (FORMAT NIL "~D" POINT-SIZE)
+                                      (OR (SECOND SEGMENT) "")))
+        (SETQ FONTNAME (INTERN (STRING-UPCASE FONTNAME) "FONTS"))
+        (SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME
+                                       MAKE-ARRAY (:LENGTH (1+ EC))))
+        (SETF (FD-FILL-POINTER FD) (1+ EC))
+        (SETF (FD-VERT-RESOLUTION FD) (NTH 9 SEGMENT))
+        (SETF (FD-HORIZ-RESOLUTION FD) (NTH 8 SEGMENT))
+        (SETF (FD-ROTATION FD) (NTH 5 SEGMENT))
+        (DO ((HEIGHT 0)
+             (I BC (1+ I)))
+            ((> I EC)
+             (SETQ LINE-HEIGHT (+ HEIGHT BASELINE))
+             (SETF (FD-LINE-SPACING FD) LINE-HEIGHT)
+             (SETF (FD-BLINKER-HEIGHT FD) LINE-HEIGHT)
+             (SETF (FD-BASELINE FD) (- LINE-HEIGHT BASELINE)))
+          (COND (( (AREF BOX-Y-SIZE I) -1)
+                 (SETQ HEIGHT (MAX HEIGHT (+ (AREF BOX-Y-SIZE I) (AREF BOX-Y-OFFSET I))))))
+          (COND (( (AREF BOX-Y-SIZE I) -1)
+                 (SETQ BASELINE (MAX BASELINE (- (AREF BOX-Y-OFFSET I)))))))
+        (DO ((CH BC (1+ CH))
+             (CHAR-WIDTH)
+             (RASTER-HEIGHT)
+             (RASTER-WIDTH)
+             (CHAR-Y-OFFSET)
+             (WD)
+             (CD))
+            ((> CH EC))
+          (COND (( (AREF BOX-Y-SIZE CH) -1)
+                 (SETQ CHAR-WIDTH (AREF XWIDTHS CH))
+                 (SETQ RASTER-WIDTH (AREF BOX-X-SIZE CH))
+                 (SETQ RASTER-HEIGHT (AREF BOX-Y-SIZE CH))
+                 (SETQ CHAR-Y-OFFSET (AREF BOX-Y-OFFSET CH))
+                 (SETQ CD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (:TYPE ART-1B
+                                                            :LENGTH (LIST LINE-HEIGHT
+                                                                          RASTER-WIDTH))))
+                 (SETF (CD-CHAR-WIDTH CD) CHAR-WIDTH)
+                 (SETF (CD-CHAR-VERT-WIDTH CD) (AREF YWIDTHS CH))
+                 (AND (= CH #\SP) (SETF (FD-SPACE-WIDTH FD) CHAR-WIDTH))
+                 (SETF (CD-CHAR-LEFT-KERN CD) (- (AREF BOX-X-OFFSET CH)))
+                 ;; Store the CD in the font descriptor
+                 (ASET CD FD CH)
+                 ;; Verify that the relative pointer to this character's data was right.
+                 (OR (= (AREF CHAR-DATA-POSITION CH)
+                        (FUNCALL INPUT-FILE ':READ-POINTER))
+                     (FERROR NIL "Inconsistent character data pointer for character ~C" CH))
+                 ;; Skip a word of redundant info on raster height and width.
+                 (LET ((TEM (NEXT-WORD)))
+                   (OR (= TEM (DPB (// (+ RASTER-HEIGHT 17) 20) 1206 RASTER-WIDTH))
+                       (FERROR NIL
+        "Inconsistent raster size data at front of character bits for character ~C"
+                               CH)))
+                 ;; Raster lines go vertically up, leftmost line first.
+                 (DOTIMES (HPOS RASTER-WIDTH)
+                   ;; Read in the next vertical scan line.
+                   (DOTIMES (VPOS RASTER-HEIGHT)
+                     ;; If wd is exhausted, get next word into wd
+                     (COND ((ZEROP (\ VPOS 16.))
+                            (SETQ WD (NEXT-WORD))))
+                     (SETQ TEM (LDB 1701 (LSH WD (\ VPOS 16.))))
+                     (OR (
+ (+ VPOS BASELINE CHAR-Y-OFFSET) LINE-HEIGHT)
+                         (ASET TEM CD
+                               (- LINE-HEIGHT 1 (+ VPOS BASELINE CHAR-Y-OFFSET))
+                               HPOS)))))))
+        ;; Set width of blinker and space fields from the space character.
+        (SETF (FD-BLINKER-WIDTH FD) (FD-SPACE-WIDTH FD))
+        (OR (= (FUNCALL INPUT-FILE ':READ-POINTER)
+               (+ (NTH 6 SEGMENT) (NTH 7 SEGMENT)))
+            (FERROR NIL "Inconsistent data-length in index of AC file"))
+        FD))))
+
+;;; This returns in array units, which are from the upper-left corner
+(DEFUN CD-RASTER-RANGE (CD)
+  (DECLARE (RETURN-LIST MINX MINY MAXX MAXY))
+  (LOOP WITH HEIGHT = (ARRAY-DIMENSION-N 1 CD)
+        AND WIDTH = (ARRAY-DIMENSION-N 2 CD)
+        WITH MINX = WIDTH AND MINY = HEIGHT
+        AND MAXX = 0 AND MAXY = 0
+        FOR X FROM 0 BELOW WIDTH
+        DO (LOOP FOR Y FROM 0 BELOW HEIGHT
+                 WHEN (NOT (ZEROP (AREF CD Y X)))
+                 DO (SETQ MINX (MIN MINX X)
+                          MAXX (MAX MAXX (1+ X))
+                          MINY (MIN MINY Y)
+                          MAXY (MAX MAXY (1+ Y))))
+        FINALLY (RETURN (MIN MINX MAXX) (MIN MINY MAXY) MAXX MAXY)))
+
+;Return how many rasters are empty (all 0)
+;at the bottom of the character and at the top.
+(DEFUN CD-UNUSED-RASTER-HEIGHT (CD)
+  (DECLARE (RETURN-LIST BOTTOM TOP))
+  (LET* ((DIMS (ARRAY-DIMENSIONS CD))
+         BOTTOM TOP
+         (HEIGHT (CAR DIMS))
+         (WIDTH (CADR DIMS)))
+    (DOTIMES (I HEIGHT)
+      (AND (DOTIMES (J WIDTH)
+             (AND (NOT (ZEROP (AREF CD I J)))
+                  (RETURN T)))
+           (RETURN (SETQ TOP I))))
+    (DOTIMES (I HEIGHT)
+      (AND (DOTIMES (J WIDTH)
+             (AND (NOT (ZEROP (AREF CD (- HEIGHT I 1) J)))
+                  (RETURN T)))
+           (RETURN (SETQ BOTTOM I))))
+    (COND (TOP (VALUES BOTTOM TOP))
+          ;; Handle case where all data is empty.
+          (T (VALUES HEIGHT 0)))))
+
+;Write an AC file from a Lisp machine font.
+(DEFUN WRITE-FONT-INTO-AC (FONTNAME &OPTIONAL FILENAME)
+  (MULTIPLE-VALUE (FONTNAME FILENAME)
+    (GET-OUTPUT-FILENAME-AND-FONTNAME FONTNAME FILENAME "AC"))
+  (LET ((FD (FONT-NAME-FONT-DESCRIPTOR FONTNAME)))
+    (WRITE-FONT-DESCRIPTOR-INTO-AC FD FILENAME)))
+
+(DEFUN WRITE-FONT-DESCRIPTOR-INTO-AC (FD &OPTIONAL FILENAME
+                                         &AUX FAMILY-NAME FACE-CODE POINT-SIZE BC EC)
+  (SETQ FILENAME (GET-OUTPUT-FILENAME-FROM-FONT-DESCRIPTOR FD FILENAME "AC"))
+  (SETF (VALUES FAMILY-NAME FACE-CODE POINT-SIZE)
+        (PRESS:DECODE-FONT-NAME (STRING (FD-NAME FD))))
+  (WITH-OPEN-FILE (OUTPUT-FILE FILENAME '(:WRITE :FIXNUM))
+    (LET* ((FONT-LENGTH (ARRAY-ACTIVE-LENGTH FD))
+           UNUSED-TOP-RASTERS UNUSED-BOTTOM-RASTERS
+           CHAR-DATA-SIZE-TABLE (TOTAL-DATA-SIZE 0))
+
+      (AND (> FONT-LENGTH 400)
+           (PROGN (SETQ FONT-LENGTH 400)
+                  (CERROR T NIL NIL "Font contains codes above 377 which AC file cannot hold"
+                          )))
+
+      (SETQ UNUSED-TOP-RASTERS (MAKE-ARRAY FONT-LENGTH)
+            UNUSED-BOTTOM-RASTERS (MAKE-ARRAY FONT-LENGTH))
+
+      ;; Figure out range of chars to actually output.
+      (DOTIMES (I FONT-LENGTH)
+        (AND (AREF FD I) (RETURN (SETQ BC I))))
+      (DO ((I (1- FONT-LENGTH) (1- I)))
+          ((MINUSP I))
+        (AND (AREF FD I) (RETURN (SETQ EC I))))
+
+      ;; Precompute how much data each character is going to require.
+      ;; Count number of words of rasters, plus 1 word of info before them.
+      (SETQ CHAR-DATA-SIZE-TABLE (MAKE-ARRAY FONT-LENGTH))
+      (DOTIMES (CHAR-CODE FONT-LENGTH)
+        (LET* ((CD (AREF FD CHAR-CODE))
+               (DATA-SIZE 0))
+          (AND CD
+               (MULTIPLE-VALUE-BIND (TEM1 TEM2)
+                   (CD-UNUSED-RASTER-HEIGHT CD)
+                 (SETF (AREF UNUSED-BOTTOM-RASTERS CHAR-CODE) TEM1)
+                 (SETF (AREF UNUSED-TOP-RASTERS CHAR-CODE) TEM2)
+                 (SETQ DATA-SIZE (1+ (* (// (+ (- (ARRAY-DIMENSION-N 1 CD) TEM1 TEM2) 17) 20)
+                                        (ARRAY-DIMENSION-N 2 CD))))))
+          (SETQ TOTAL-DATA-SIZE (+ TOTAL-DATA-SIZE DATA-SIZE))
+          (SETF (AREF CHAR-DATA-SIZE-TABLE CHAR-CODE) DATA-SIZE)))
+      (SETQ TOTAL-DATA-SIZE (+ TOTAL-DATA-SIZE (* 10. (- EC BC -1))))
+      ;; Index entry type 1, 12. words long.
+      (FUNCALL OUTPUT-FILE ':TYO (DPB 1 1404 12.))
+      ;; Family code - always 1, since we only write one family.
+      (FUNCALL OUTPUT-FILE ':TYO 1)
+      ;; Write the family name now.
+      (DO ((I 0 (1+ I))
+           (LEN (STRING-LENGTH FAMILY-NAME))
+           (HIGH-BYTE (STRING-LENGTH FAMILY-NAME)))
+          ((= I 19.))
+        (LET ((CH (IF (< I LEN)
+                      (AREF FAMILY-NAME I)
+                      0)))
+          (IF HIGH-BYTE
+              (PROGN (FUNCALL OUTPUT-FILE ':TYO
+                              (DPB HIGH-BYTE 1010 CH))
+                     (SETQ HIGH-BYTE NIL))
+              (SETQ HIGH-BYTE CH))))
+      ;; Now write the index entry for the data segment.
+      ;; Type 3, 11. words long.
+      (FUNCALL OUTPUT-FILE ':TYO (DPB 3 1404 11.))
+      ;; Now family code and face code.
+      (FUNCALL OUTPUT-FILE ':TYO (DPB 1 1010 (PRESS:ENCODE-PRESS-FACE FACE-CODE)))
+      ;; Now range of characters actually existing in the font.
+      (FUNCALL OUTPUT-FILE ':TYO (DPB BC 1010 EC))
+      ;; Now size of font.
+      (FUNCALL OUTPUT-FILE ':TYO (// (+ (* POINT-SIZE 2540.) 36.) 72.))
+      ;; Rotation is 0.
+      (FUNCALL OUTPUT-FILE ':TYO 0)
+      ;; Position in file of start of data (2 words).
+      (FUNCALL OUTPUT-FILE ':TYO 0)
+      (FUNCALL OUTPUT-FILE ':TYO 24.)
+      ;; Number of words of data.
+      (FUNCALL OUTPUT-FILE ':TYO (LDB 2020 TOTAL-DATA-SIZE))
+      (FUNCALL OUTPUT-FILE ':TYO (LDB 0020 TOTAL-DATA-SIZE))
+      ;; Resolutions
+      (FUNCALL OUTPUT-FILE ':TYO (FD-HORIZ-RESOLUTION FD))
+      (FUNCALL OUTPUT-FILE ':TYO (FD-VERT-RESOLUTION FD))
+      ;; Index entry type 0, end of index.
+      (FUNCALL OUTPUT-FILE ':TYO 1)
+     
+      ;; Output descriptions of the characters in the font.
+      (DO ((CHAR-CODE BC (1+ CHAR-CODE)))
+          ((> CHAR-CODE EC))
+        (LET ((CD (AREF FD CHAR-CODE)))
+          (COND ((NULL CD)
+                 (FUNCALL OUTPUT-FILE ':TYO 0)
+                 (FUNCALL OUTPUT-FILE ':TYO 0)
+                 (FUNCALL OUTPUT-FILE ':TYO 0)
+                 (FUNCALL OUTPUT-FILE ':TYO 0)
+                 (FUNCALL OUTPUT-FILE ':TYO 0)
+                 (FUNCALL OUTPUT-FILE ':TYO 0)
+                 (FUNCALL OUTPUT-FILE ':TYO 0)
+                 (FUNCALL OUTPUT-FILE ':TYO -1))
+                (T
+                 (FUNCALL OUTPUT-FILE ':TYO (FIX (CD-CHAR-WIDTH CD)))
+                 (FUNCALL OUTPUT-FILE ':TYO
+                          (FIX (* 65536. (- (CD-CHAR-WIDTH CD) (FIX (CD-CHAR-WIDTH CD))))))
+                 (FUNCALL OUTPUT-FILE ':TYO (FIX (CD-CHAR-VERT-WIDTH CD)))
+                 (FUNCALL OUTPUT-FILE ':TYO
+                          (FIX (* 65536. (- (CD-CHAR-VERT-WIDTH CD)
+                                            (FIX (CD-CHAR-VERT-WIDTH CD))))))
+                 (FUNCALL OUTPUT-FILE ':TYO (- (CD-CHAR-LEFT-KERN CD)))
+                 (FUNCALL OUTPUT-FILE ':TYO (+ (- (FD-BASELINE FD)
+                                                  (FD-LINE-SPACING FD))
+                                               (AREF UNUSED-BOTTOM-RASTERS CHAR-CODE)))
+                 (FUNCALL OUTPUT-FILE ':TYO (CADR (ARRAY-DIMENSIONS CD)))
+                 (FUNCALL OUTPUT-FILE ':TYO (- (CAR (ARRAY-DIMENSIONS CD))
+                                               (AREF UNUSED-BOTTOM-RASTERS CHAR-CODE)
+                                               (AREF UNUSED-TOP-RASTERS CHAR-CODE)))))))
+      ;; Output offsets to data for each character.
+      (LET* ((CURRENT-POS (+ 24. (* 8 (- EC BC -1))))
+             (EXPECTED-DATA-START
+               (+ CURRENT-POS (* 2 (- EC BC -1)))))
+        (DO ((CHAR-CODE BC (1+ CHAR-CODE)))
+            ((> CHAR-CODE EC))
+          (LET ((OFFSET (- EXPECTED-DATA-START CURRENT-POS)))
+            (FUNCALL OUTPUT-FILE ':TYO (LDB 2020 OFFSET))
+            (FUNCALL OUTPUT-FILE ':TYO (LDB 0020 OFFSET)))
+          (SETQ EXPECTED-DATA-START
+                (+ EXPECTED-DATA-START
+                   (AREF CHAR-DATA-SIZE-TABLE CHAR-CODE)))))
+      
+      ;; Now output the rasters themselves.
+      (DO ((CHAR-CODE BC (1+ CHAR-CODE)))
+          ((> CHAR-CODE EC))
+        (LET* (WD
+               (CD (AREF FD CHAR-CODE)))
+          (COND (CD
+                 (LET* ((RASTER-WIDTH (ARRAY-DIMENSION-N 2 CD))
+                        (RASTER-BOTTOM-SKIP (AREF UNUSED-BOTTOM-RASTERS CHAR-CODE))
+                        (REAL-RASTER-HEIGHT (ARRAY-DIMENSION-N 1 CD))
+                        (RASTER-HEIGHT (- REAL-RASTER-HEIGHT
+                                          RASTER-BOTTOM-SKIP
+                                          (AREF UNUSED-TOP-RASTERS CHAR-CODE))))
+                   ;; Output redundant raster size info word.
+                   (FUNCALL OUTPUT-FILE ':TYO
+                            (DPB (// (+ RASTER-HEIGHT 17) 20)
+                                 1206
+                                 (ARRAY-DIMENSION-N 2 CD)))
+                   ;; Raster lines go vertically up, leftmost line first.
+                   (DOTIMES (HPOS RASTER-WIDTH)
+                     (SETQ WD 0)
+                     ;; Write the next vertical scan line.
+                     (DOTIMES (VPOS RASTER-HEIGHT)
+                       (SETQ WD (+ WD (LSH (AREF CD (- REAL-RASTER-HEIGHT
+                                                       1 VPOS RASTER-BOTTOM-SKIP)
+                                                 HPOS)
+                                           
+                                           (- 17 (\ VPOS 20)))))
+                       ;; If wd is full, output it.
+                       (AND (ZEROP (\ (1+ VPOS) 16.))
+                            (PROGN (FUNCALL OUTPUT-FILE ':TYO WD)
+                                   (SETQ WD 0))))
+                     ;; Output partially-filled word at end.
+                     (OR (ZEROP (\ RASTER-HEIGHT 16.))
+                         (FUNCALL OUTPUT-FILE ':TYO WD)))))))))
+    (FUNCALL OUTPUT-FILE ':CLOSE)
+    (FUNCALL OUTPUT-FILE ':TRUENAME)))
+
+(DEFUN READ-AST-INTO-FONT (FILENAME &OPTIONAL FONTNAME)
+  (MULTIPLE-VALUE (FILENAME FONTNAME)
+    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AST"))
+  (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME
+                                     (READ-AST-INTO-FONT-DESCRIPTOR FILENAME FONTNAME))
+  FONTNAME)
+
+(DEFUN READ-AST-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME &AUX FD)
+  (MULTIPLE-VALUE (FILENAME FONTNAME)
+    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AST"))
+  (WITH-OPEN-FILE (STREAM FILENAME '(:IN))
+    (SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME MAKE-ARRAY (:LENGTH 200)))
+    (READ-AST-DN STREAM)                        ;DISCARD KSTID
+    (SETF (FD-LINE-SPACING FD) (READ-AST-DN STREAM))
+    (SETF (FD-BASELINE FD) (READ-AST-DN STREAM))
+    (READ-AST-DN STREAM)                        ;COLUMN POSITION ADJUSTMENT
+    (SETF (FD-SPACE-WIDTH FD) 0)                ;Just in case no space character.
+    (SETF (FD-BLINKER-HEIGHT FD)
+          (FD-LINE-SPACING FD))
+    (SETF (FD-NAME FD) FONTNAME)
+    (LET (KERN CHAR-CODE RASTER-WIDTH INPUT-RASTER-WIDTH CHAR-WIDTH
+          CD CH (LINE-HEIGHT (FD-LINE-SPACING FD)))
+      (DO ()
+          ((NULL (READ-AST-NEXT-PAGE STREAM)))
+        (SETQ CHAR-CODE (READ-AST-ON STREAM))
+        (SETQ INPUT-RASTER-WIDTH (READ-AST-DN STREAM) RASTER-WIDTH INPUT-RASTER-WIDTH)
+        (SETQ CHAR-WIDTH (READ-AST-DN STREAM))
+        (SETQ KERN (READ-AST-DN STREAM))
+        (COND ((< KERN 0)                       ;FED COMPACT RASTER LOSSAGE
+               (SETQ RASTER-WIDTH (+ RASTER-WIDTH (ABS KERN)))
+               (SETQ KERN 0)))
+        (SETQ CD (MAKE-CHAR-DESCRIPTOR
+                   MAKE-ARRAY (:TYPE ART-1B :LENGTH (LIST LINE-HEIGHT RASTER-WIDTH))))
+        (SETF (CD-CHAR-WIDTH CD) CHAR-WIDTH)
+        (SETF (CD-CHAR-LEFT-KERN CD) KERN)
+        (FD-STORE-CD FD CD CHAR-CODE)
+        (AND (= CHAR-CODE #\SP)
+             (SETF (FD-SPACE-WIDTH FD) CHAR-WIDTH))
+        (DO-NAMED TOP ((VPOS 0 (1+ VPOS)))
+                  ((= VPOS LINE-HEIGHT))
+          (DO ((HCNT 0 (1+ HCNT)))
+              ((= HCNT INPUT-RASTER-WIDTH)
+               (DO ((CH)) ()
+                 (COND ((OR (NULL (SETQ CH (FUNCALL STREAM ':TYI)))
+                            (= CH #\RETURN))
+                        (RETURN NIL))
+                       ((NOT (= CH #\SPACE))
+                        (FERROR NIL "non space seen past raster width")))))
+            (SETQ CH (FUNCALL STREAM ':TYI))
+            (COND ((NULL CH)
+                   (RETURN-FROM TOP NIL))
+                  ((= CH #\FORM)
+                   (FUNCALL STREAM ':UNTYI CH)
+                   (RETURN-FROM TOP NIL))
+                  ((OR (< CH 40) (> CH 200))
+                   (DO () ((= CH #\RETURN)) (SETQ CH (FUNCALL STREAM ':TYI)))
+                   (RETURN NIL))
+                  ((> CH 40)
+                   (ASET 1 CD VPOS (+ HCNT (- RASTER-WIDTH INPUT-RASTER-WIDTH)))))))
+     ; (COND ((> CHAR-CODE 37) (TYO CHAR-CODE))
+     ;        (T (PRINC '^) (TYO (+ 100 CHAR-CODE))))
+        )
+      ;; Truncate fd to discard unused elements at the end.
+      (DO ((I (1- (ARRAY-LENGTH FD)) (1- I)))
+          ((OR (MINUSP I)
+               (AREF FD I))
+           (ADJUST-ARRAY-SIZE FD (1+ I))))
+      (SETF (FD-FILL-POINTER FD) (ARRAY-LENGTH FD))
+      ;; Set width of blinker and space fields from the space character.
+      (SETF (FD-BLINKER-WIDTH FD)
+            (FD-SPACE-WIDTH FD))
+      FD)))
+
+(DEFUN READ-AST-DN (STREAM)
+  (PROG (N CH SIGN)
+    (SETQ N 0 SIGN 1)
+    (SETQ CH (FUNCALL STREAM ':TYI))            ;LOOK FOR MINUS SIGN
+    (COND ((= CH #/-)
+           (SETQ SIGN -1))
+          (T (GO AA)))
+ A   (SETQ CH (FUNCALL STREAM ':TYI))
+ AA  (AND (
+ CH #/0) (
+ CH #/9)
+          (PROGN
+            (SETQ N (+ (* N 10.) (- CH #/0)))
+            (GO A)))
+ B   (AND (= CH #\RETURN) (RETURN (* N SIGN)))
+    (SETQ CH (FUNCALL STREAM ':TYI))
+    (GO B)))
+
+(DEFUN READ-AST-ON (STREAM)
+  (PROG (N CH)
+    (SETQ N 0)
+A   (SETQ CH (FUNCALL STREAM ':TYI))
+    (AND (
+ CH #/0) (
+ CH #/8)
+         (PROGN
+           (SETQ N (+ (* N 8) (- CH #/0)))
+           (GO A)))
+B   (AND (= CH #\RETURN) (RETURN N))
+    (SETQ CH (FUNCALL STREAM ':TYI))
+    (GO B)))
+
+(DEFUN READ-AST-NEXT-PAGE (STREAM)
+  (PROG (CH)
+    (COND ((NULL (SETQ CH (FUNCALL STREAM ':TYI))) (RETURN NIL))
+          ((= CH #\FORM)
+           (SETQ CH (FUNCALL STREAM ':TYI))
+           (FUNCALL STREAM ':UNTYI CH)
+           (IF (NULL CH)
+               (RETURN NIL)
+               (RETURN T)))
+          (T (FERROR NIL "Random char where FF expected")))))
+
+(DEFUN WRITE-FONT-INTO-AST (FONTNAME &OPTIONAL FILENAME)
+  (MULTIPLE-VALUE (FONTNAME FILENAME)
+    (GET-OUTPUT-FILENAME-AND-FONTNAME FONTNAME FILENAME "AST"))
+  (LET ((FD (FONT-NAME-FONT-DESCRIPTOR FONTNAME)))
+    (WRITE-FONT-DESCRIPTOR-INTO-AST FD FILENAME)))
+
+(DEFUN WRITE-FONT-DESCRIPTOR-INTO-AST (FD &OPTIONAL FILENAME
+                                          &AUX (FONT-LENGTH (ARRAY-ACTIVE-LENGTH FD)))
+  (SETQ FILENAME (GET-OUTPUT-FILENAME-FROM-FONT-DESCRIPTOR FD FILENAME "AST"))
+  (WITH-OPEN-FILE (STREAM FILENAME '(:OUT :ASCII))
+    (FORMAT STREAM "0 KSTID ~A"  FILENAME)
+    (FORMAT STREAM "~%~D HEIGHT" (FD-LINE-SPACING FD))
+    (FORMAT STREAM "~%~D BASE LINE" (FD-BASELINE FD))
+    (FORMAT STREAM "~%0 COLUMN POSITION ADJUSTMENT~%")
+    ;; Then write out all the characters.
+    (LET (CD CHAR-HEIGHT)
+      (DOTIMES (CHAR-CODE FONT-LENGTH)
+        (COND ((AND (SETQ CD (AREF FD CHAR-CODE))
+                      ;; Wide fonts without chars-exist-tables can have 0-width chars.
+                    (OR (NOT (ZEROP (ARRAY-DIMENSION-N 2 CD)))
+                        (NOT (ZEROP (CD-CHAR-WIDTH CD)))))
+               (FUNCALL STREAM ':TYO #\FORM)
+               (FORMAT STREAM "~O CHARACTER CODE ~A" CHAR-CODE FILENAME)
+               (FORMAT STREAM "~%~D RASTER WIDTH" (ARRAY-DIMENSION-N 2 CD))
+               (FORMAT STREAM "~%~D CHARACTER WIDTH" (CD-CHAR-WIDTH CD))
+               (FORMAT STREAM "~%~D LEFT KERN~%" (CD-CHAR-LEFT-KERN CD))
+               (SETQ CHAR-HEIGHT (ARRAY-DIMENSION-N 1 CD))
+               (DOTIMES (VPOS CHAR-HEIGHT)
+                 (DOTIMES (HPOS (ARRAY-DIMENSION-N 2 CD))
+                   (FUNCALL STREAM ':TYO (IF (ZEROP (AREF CD VPOS HPOS))
+                                             #\SPACE
+                                             #/*)))
+                 (FUNCALL STREAM ':TYO #\RETURN))))))
+    (FUNCALL STREAM ':CLOSE)
+    (FUNCALL STREAM ':TRUENAME)))
+ 

trunk/lisp/lmio1/fntdef.lisp

@@ -1 @@
-;These are the definitions for the new font hacking stuff       -*-LISP-*-
+;These are the definitions for the new font hacking stuff       -*-Mode:LISP; Package:fed-*-
 
 ;The elements of a FONT-DESCRIPTOR are either NIL or a CHAR-DESCRIPTOR.
 ;If NIL then this character is not defined for this font.
 
-(DEFSTRUCT (FONT-DESCRIPTOR :ARRAY-LEADER :NAMED
-                                  (:MAKE-ARRAY (NIL 'ART-Q 200)))
-           FD-FILL-POINTER
+(DEFSTRUCT (FONT-DESCRIPTOR :ARRAY-LEADER :NAMED)
+           (FD-FILL-POINTER 0)
            FD-NAME
            FD-LINE-SPACING              ;Vertical distance between baselines.
@@ -15 +14 @@
            FD-BLINKER-WIDTH             ;Width of a "blinker" in this font.
            FD-SPACE-WIDTH               ;Width of a space.
-           FD-DOUBLE-WIDTH-P)           ;T means this font is intended for display
+           FD-DOUBLE-WIDTH-P            ;T means this font is intended for display
                                         ;with twice as many pixels per unit distance
                                         ;in the horizontal direction. (ESCAPE 7)
+
+                                        ;The rest is for saving info that
+                                        ;comes in Xerox fonts, so we don't lose it.
+           (FD-VERT-RESOLUTION 3840.)   ;Dots per inch, times ten.
+           (FD-HORIZ-RESOLUTION 3840.)  ;" "
+                                        ;Default is right for the Dover.
+           (FD-ROTATION 0)              ;Rotation in degrees.
+           )
 
 ;A CHAR-DESCRIPTOR is a two dimensional array (with leader).
@@ -26 +33 @@
            CD-NAME
            CD-CHAR-WIDTH                ;The horizontal distance taken by this character
+           CD-CHAR-VERT-WIDTH           ;Vertical spacing caused by this character
+                                        ;(always 0 for the usual horizontal font).
+                                        ;For the sake of Xerox fonts.
            CD-CHAR-LEFT-KERN)           ;The distance to the left to move before placing the
                                         ;character.  A left kern of -5 means the array is to

trunk/lisp/lmio1/press.lisp

@@ -1 @@
-;;; -*- Mode:Lisp; Package:Press; base:8.; ibase:8. -*-
-
-;;;; PRESS File and DOVER software
-
-(DEFVAR PRESS-USE-EFTP NIL)     ;T => EFTP, NIL => Chaos
-(DEFVAR DOVER-ADDRESS 1002)     ;2#2#
-(DEFVAR 926-ALTO-ADDRESS 1140)  ;Alto in Moon's office
-                                ;CADR-6 is 1#36# as far as Xerox is concerned
-
-(EVAL-WHEN (EVAL COMPILE LOAD)
-     (OR (FBOUNDP 'CHAOS:GET-PUP) (LOAD "AI;LMIO1;EFTP QFASL")))
+;;; -*- Mode:Lisp; Package:Press; Base:8 -*-
+;;; PRESS File and DOVER software
+;;; ** (c) Copyright 1981 Massachusetts Institute of Technology **
+
+(DEFVAR PRESS-SPECIAL-VARIABLES NIL)
+
+(DEFMACRO DEFINE-PRESS-VARIABLE (NAME &OPTIONAL FORM (DEFVAR-P T))
+  `(SI:DEFINE-SPECIAL-VARIABLE ,NAME ,FORM PRESS-SPECIAL-VARIABLES ,DEFVAR-P))
+
+(DEFMACRO BIND-PRESS-VARIABLES (&BODY BODY)
+  `(PROGW PRESS-SPECIAL-VARIABLES
+     (UNWIND-PROTECT
+       (PROGN . ,BODY)
+       (DEALLOCATE-RESOURCE 'PRESS-PAGE-ENTITY-BUFFER PRESS-PAGE-ENTITY-BUFFER))))
+
+(DEFINE-PRESS-VARIABLE PRESS-USE-EFTP NIL)      ;T => EFTP, NIL => Chaos
+(DEFVAR DOVER-ADDRESS 1002)                     ;2#2#
 
 ;Don't get too strung out by the little frob at the end of the message.
 (DEFUN PRINT-DOVER-STATUS ()
-  (DO ((N-RETRIES 10. (1- N-RETRIES))
-       (PORT (CHAOS:GET-PORT-NUMBER))
-       (PUP))
-      ((ZEROP N-RETRIES)
-       (FORMAT T "~&Dover is not responding (may be printing).~%"))
-    (CHAOS:TRANSMIT-PUP (CHAOS:GET-PUP DOVER-ADDRESS 21 PORT 200 0) 0)
-    (COND ((SETQ PUP (CHAOS:RECEIVE-PUP PORT))
-           (COND ((= (CHAOS:PUP-TYPE PUP) 201)
-                  (FORMAT T "~&Dover status: ~[~;Spooler shut off.~;Spooler available.~;Spooler busy.~]  ~A~%"
-                            (AREF PUP 22.)
-                            (CHAOS:PUP-STRING PUP 2))
-                  (CHAOS:FREE-INT-PKT PUP)
-                  (RETURN T))
-                 (T (CHAOS:RECEIVED-RANDOM-PUP PUP)))))))
+  (LET ((CONN (CHAOS:OPEN-FOREIGN-CONNECTION DOVER-ADDRESS 21)))
+    (UNWIND-PROTECT
+      (DO ((N-RETRIES 10. (1- N-RETRIES))
+           (PUP))
+          ((ZEROP N-RETRIES)
+           (FORMAT T "~&Dover is not responding (may be printing).~%"))
+        (CHAOS:TRANSMIT-PUP CONN (CHAOS:GET-PUP CONN 200 0) 0)
+        (COND ((SETQ PUP (CHAOS:RECEIVE-PUP CONN))
+               (COND ((= (CHAOS:PUP-TYPE PUP) 201)
+                      (FORMAT T "~&Dover status: ~[~;Spooler shut off.~;Spooler available.~
+                                 ~;Spooler busy.~]  ~A~%"
+                              (CHAOS:PUP-WORD PUP 0)
+                              (CHAOS:PUP-STRING PUP 2))
+                      (CHAOS:RETURN-PKT PUP)
+                      (RETURN T))
+                     (T (CHAOS:RECEIVED-RANDOM-PUP PUP))))))
+      (CHAOS:REMOVE-CONN CONN))))
+
+(DEFUN PRINT-DOVER-QUEUE ()
+  ;; Avoid opening a new file job to MC if logged in to AI.
+  (FS:VIEWF (IF (EQ FS:USER-LOGIN-MACHINE
+                    (SI:PARSE-HOST "AI"))
+                "AI: DVR: FOO; .FILE. (DIR)"
+                "MC: DVR: FOO; .FILE. (DIR)")))
 
 ;;; Routines for building Press pages and shipping them out an EFTP connection
@@ -32 +48 @@
 ;;; Later this might be made into a more stream-like thing (as a "resource")
 
-(DEFVAR PRESS-EFTP-STREAM)                      ;EFTP connection we send through
-(DEFVAR PRESS-N-CHARS)                          ;Number of characters sent this part
-(DEFVAR PRESS-CURRENT-RECORD-NUMBER)            ;Record number within file
-(DEFVAR PRESS-X)                                ;X position computed as characters sent
-(DEFVAR PRESS-Y)                                ;Y ..
-(DEFVAR PRESS-PAGE-NUMBER)                      ;Serial number of page
-(DEFVAR PRESS-END-PAGE-HOOK   NIL)              ;If non-NIL, function to call
-(DEFVAR PRESS-PENDING-CHARS)                    ;Number of chars output but not yet known
+(DEFINE-PRESS-VARIABLE PRESS-INTERPRET-XGP-ESCAPE NIL)  ;177 is special character in input
+(DEFINE-PRESS-VARIABLE PRESS-EFTP-STREAM NIL)   ;EFTP connection we send through
+(DEFINE-PRESS-VARIABLE PRESS-N-CHARS)           ;Number of characters sent this part
+(DEFINE-PRESS-VARIABLE PRESS-CURRENT-RECORD-NUMBER 0)   ;Record number within file
+(DEFINE-PRESS-VARIABLE PRESS-X)                 ;X position computed as characters sent
+(DEFINE-PRESS-VARIABLE PRESS-Y)                 ;Y ..
+(DEFINE-PRESS-VARIABLE PRESS-BASELINE-Y)        ;Baseline Y, usually the same
+(DEFINE-PRESS-VARIABLE PRESS-INTERCHAR-SPACING NIL)     ;Between all chars if non-NIL
+(DEFINE-PRESS-VARIABLE PRESS-INTERLINE-SPACING NIL)     ;Between all lines if non-NIL
+(DEFINE-PRESS-VARIABLE PRESS-PAGE-NUMBER 1)     ;Serial number of page
+(DEFINE-PRESS-VARIABLE PRESS-END-PAGE-HOOK NIL) ;If non-NIL, function to call
+(DEFINE-PRESS-VARIABLE PRESS-PENDING-CHARS)     ;Number of chars output but not yet known
                                                 ;about at the "entity" level
 
-(DEFVAR PRESS-DATA-LIST-START)                  ;Value of PRESS-N-CHARS at start of entity
-(DEFVAR PRESS-ENTITY-LIST-START)                ;Value of (size of entity buffer) at ..
+(DEFINE-PRESS-VARIABLE PRESS-DATA-LIST-START)   ;Value of PRESS-N-CHARS at start of entity
+(DEFINE-PRESS-VARIABLE PRESS-ENTITY-LIST-START) ;Value of (size of entity buffer) at ..
 
 (DEFVAR PRESS-PAGE-ENTITY-BUFFER-EXTENSION-SIZE 4000.)
-(DEFVAR PRESS-PAGE-ENTITY-BUFFER
-        (MAKE-ARRAY NIL 'ART-8B PRESS-PAGE-ENTITY-BUFFER-EXTENSION-SIZE NIL '(0)))
+(DEFRESOURCE PRESS-PAGE-ENTITY-BUFFER ()
+  :CONSTRUCTOR (MAKE-ARRAY PRESS-PAGE-ENTITY-BUFFER-EXTENSION-SIZE
+                           ':TYPE 'ART-8B
+                           ':LEADER-LIST '(0)))
+(DEFINE-PRESS-VARIABLE PRESS-PAGE-ENTITY-BUFFER (ALLOCATE-RESOURCE 'PRESS-PAGE-ENTITY-BUFFER))
                                                 ;This holds the "entity" portion of the
                                                 ;current page
 
-(DEFVAR PRESS-PART-LIST) ;List of elements (part-type record-number n-records n-padding-words)
-(DEFVAR PRESS-FONT-LIST) ;List of elements (family-name face-name point-size rotation
-                         ;                  width height width-table)
-(DEFVAR PRESS-CURRENT-FONT NIL)                 ;Element for selected font
-
-(DEFVAR DOVER-X0 2000.)                         ;2 cm left margin
-(DEFVAR DOVER-Y0 (FIX (* 9.8 2540.)))           ;Where the page number goes
-(DEFVAR DOVER-Y1 (FIX (* 9.5 2540.)))           ;Where the text starts
-(DEFVAR DOVER-Y2 (FIX (* 0.5 2540.)))           ;Margin at the bottom of the page
-(DEFVAR LINE-WIDTH 25.)                         ;Line width .01 inch
+(DEFINE-PRESS-VARIABLE PRESS-PART-LIST NIL)     ;List of elements (part-type record-number
+                                                ;                  n-records n-padding-words)
+(DEFINE-PRESS-VARIABLE PRESS-FONT-LIST NIL)     ;List of elements (family-name face-name
+                                                ;                  point-size rotation
+                                                ;                  width height width-table)
+(DEFINE-PRESS-VARIABLE PRESS-CURRENT-FONT NIL)  ;Element for selected font
+
+(DEFINE-PRESS-VARIABLE DOVER-X0 2000.)          ;2 cm left margin
+(DEFINE-PRESS-VARIABLE DOVER-Y0 (FIX (* 9.8 2540.)))    ;Where the page number goes
+(DEFINE-PRESS-VARIABLE DOVER-Y1 (FIX (* 9.5 2540.)))    ;Where the text starts
+(DEFINE-PRESS-VARIABLE DOVER-Y2 (FIX (* 0.5 2540.)))    ;Margin at the bottom of the page
+(DEFINE-PRESS-VARIABLE LINE-WIDTH 25.)          ;Line width .01 inch
 ;(DEFVAR DIAGONAL-LINE-WIDTH 18.)               ;Make darkness come out even
 ;This provides nice thin lines, for thinner lines you might want 2 instead of 4
@@ -78 +103 @@
 ;       226-232    The 1.-bit box
 ;       240        The 0-bit box (or isolated point).
+
+(DEFINE-PRESS-VARIABLE PRESS-XGP-UNDERLINE-START-X)
+(DEFINE-PRESS-VARIABLE PRESS-XGP-FONT-LIST NIL)
 
 ;;;; Output to the Data and Entity Lists
@@ -196 +224 @@
 
 (DEFUN PRESS-START-FILE (&OPTIONAL (HOST-ADDRESS DOVER-ADDRESS))
-  (FS:FILE-BIND-DEFAULTS
-    (OR (FBOUNDP 'LOAD-FONT-WIDTHS) (LOAD "AI:LMIO1;RFONTW QFASL"))
-    (OR (BOUNDP 'FONT-WIDTH-DATA) (LOAD-FONT-WIDTHS))
-    (SETQ PRESS-EFTP-STREAM
-          (IF (NUMBERP HOST-ADDRESS)
-              (IF PRESS-USE-EFTP (CHAOS:MAKE-EFTP-WRITE-STREAM HOST-ADDRESS T)
-                  (LET ((CONN (CHAOS:CONNECT 426 "DOVER")))
-                    (AND (STRINGP CONN)
-                         (FERROR NIL
-                                 "~A - cannot connect to DOVER server at AI-CHAOS-11" CONN))
-                    (CHAOS:STREAM CONN)))
-              (OPEN (SI:FILE-PARSE-NAME
-                      HOST-ADDRESS NIL
-                      (SI:FILE-PARSE-NAME (FORMAT NIL "MC:.DOVR.;~A >" USER-ID)))
-                    '(:WRITE :FIXNUM :BYTE-SIZE 8)))
-          PRESS-CURRENT-RECORD-NUMBER 0
-          PRESS-PART-LIST NIL
-          PRESS-FONT-LIST NIL                   ;this is a crock ***
-          PRESS-PAGE-NUMBER 1
-          )))
-
+  (OR (BOUNDP 'FONT-WIDTH-DATA)
+      (LOAD-FONT-WIDTHS "SYS: PRESS-FONTS; FONTS WIDTHS >"))
+  (SETQ PRESS-EFTP-STREAM (PRESS-OPEN-EFTP-STREAM HOST-ADDRESS DOVER-ADDRESS)))
+
+(DEFUN PRESS-OPEN-EFTP-STREAM (HOST-ADDRESS DOVER-ADDRESS)
+  (IF (NUMBERP HOST-ADDRESS)
+      (IF PRESS-USE-EFTP (CHAOS:MAKE-EFTP-WRITE-STREAM HOST-ADDRESS T)
+          (LET ((CONN (CHAOS:CONNECT "AI-CHAOS-11" "DOVER")))
+            (AND (STRINGP CONN)
+                 (FERROR NIL
+                         "~A - cannot connect to DOVER server at AI-CHAOS-11" CONN))
+            (CHAOS:STREAM CONN)))
+      (OPEN HOST-ADDRESS '(:WRITE :FIXNUM :BYTE-SIZE 8))))
 
 ;;;; Finish Press File
@@ -273 +293 @@
   (FUNCALL PRESS-EFTP-STREAM ':STRING-OUT PRESS-PAGE-ENTITY-BUFFER)
   (PRESS-FINISH-PART (ARRAY-LEADER PRESS-PAGE-ENTITY-BUFFER 0) 1)
-  ;; Except for :CLOSE itself this is superfluous except
-  ;; when going through the AI-CHAOS-11 dover server
-  (AND (MEMQ ':EOF (FUNCALL PRESS-EFTP-STREAM ':WHICH-OPERATIONS))
-       (FUNCALL PRESS-EFTP-STREAM ':EOF))
-  (FUNCALL PRESS-EFTP-STREAM ':CLOSE))
+  (FUNCALL PRESS-EFTP-STREAM ':CLOSE)
+  (FUNCALL PRESS-EFTP-STREAM ':SEND-IF-HANDLES ':TRUENAME))
 
 ;;;; Pages
@@ -347 +364 @@
 ;Finish the current entity.  You can start another if you like.
 (DEFUN PRESS-CLOSE-ENTITY (&OPTIONAL (X-OFF DOVER-X0) (Y-OFF DOVER-Y2)
-                                     (WIDTH (*  8. 2540.)) (HEIGHT (* 11. 2540.)))
+                                     (WIDTH (*  85. 254.)) (HEIGHT (* 11. 2540.)))
   (PRESS-PUT-PENDING-CHARS)
   ;; Pad entity to word boundary with NOP
@@ -424 +441 @@
                                       (THIRD PRESS-CURRENT-FONT)
                                       (SECOND PRESS-CURRENT-FONT))
-               (SETQ PRESS-X (+ WIDTH PRESS-X)))))
+               (SETQ PRESS-X (+ WIDTH PRESS-X))))
+         (AND PRESS-INTERCHAR-SPACING
+              (PRESS-SET-CURSOR (+ PRESS-X PRESS-INTERCHAR-SPACING) PRESS-Y)))
         ((= CHAR #\TAB)
          ;; The bounding box seems to be wedged, it's not the same as the character
@@ -431 +450 @@
            (PRESS-SET-CURSOR (* (1+ (// PRESS-X TAB-WIDTH)) TAB-WIDTH) PRESS-Y)))
         ((= CHAR #\CR)
-         (LET ((Y (- PRESS-Y (SIXTH PRESS-CURRENT-FONT))))
+         (LET ((Y (- PRESS-Y (OR PRESS-INTERLINE-SPACING (SIXTH PRESS-CURRENT-FONT)))))
            (IF (MINUSP Y) (PRESS-CHAR #\FORM)
-               (PRESS-SET-CURSOR 0 Y))))
+               (PRESS-SET-CURSOR 0 Y)))
+         (SETQ PRESS-BASELINE-Y PRESS-Y
+               PRESS-INTERCHAR-SPACING NIL))
         ((= CHAR #\FORM)
          (PRESS-END-PAGE)
-         (PRESS-START-PAGE)))
+         (PRESS-START-PAGE)
+         (SETQ PRESS-INTERCHAR-SPACING NIL)))
   NIL)
 
@@ -454 +476 @@
 ;Add a font to the font set and return its font number
 (DEFUN PRESS-DEFINE-FONT (FAMILY-NAME FACE-NAME POINT-SIZE ROTATION)
-  (LET ((WIDTH (GET-FONT-WIDTH-AND-HEIGHT FAMILY-NAME FACE-NAME POINT-SIZE))
-        HEIGHT WIDTH-ARRAY FONT-DESC FONT-NUMBER)
-    (SETQ HEIGHT (CADR WIDTH) WIDTH (CAR WIDTH))        ;Bounding box for font
-    (SETQ WIDTH-ARRAY (GET-FONT-WIDTH-DATA FAMILY-NAME FACE-NAME POINT-SIZE))
-    (SETQ FONT-DESC (LIST FAMILY-NAME FACE-NAME POINT-SIZE ROTATION
-                          WIDTH HEIGHT WIDTH-ARRAY))
-    (OR (MEMBER FONT-DESC PRESS-FONT-LIST)
-        (SETQ PRESS-FONT-LIST (NCONC PRESS-FONT-LIST (NCONS FONT-DESC))))
-    (SETQ FONT-NUMBER (FIND-POSITION-IN-LIST-EQUAL FONT-DESC PRESS-FONT-LIST))
-    (AND (
+  (OR (PRESS-LOOKUP-FONT FAMILY-NAME FACE-NAME POINT-SIZE ROTATION)
+      (LET ((WIDTH (GET-FONT-WIDTH-AND-HEIGHT FAMILY-NAME FACE-NAME POINT-SIZE))
+            HEIGHT WIDTH-ARRAY FONT-DESC FONT-NUMBER)
+        (SETQ HEIGHT (CADR WIDTH) WIDTH (CAR WIDTH))    ;Bounding box for font
+        (SETQ WIDTH-ARRAY (GET-FONT-WIDTH-DATA FAMILY-NAME FACE-NAME POINT-SIZE))
+        (SETQ FONT-DESC (LIST FAMILY-NAME FACE-NAME POINT-SIZE ROTATION
+                              WIDTH HEIGHT WIDTH-ARRAY))
+        (SETQ PRESS-FONT-LIST (NCONC PRESS-FONT-LIST (NCONS FONT-DESC)))
+        (SETQ FONT-NUMBER (1- (LENGTH PRESS-FONT-LIST)))
+        (AND (
  FONT-NUMBER 16.) (FERROR NIL "Maximum of 16 fonts allowed."))
-    FONT-NUMBER))
+        FONT-NUMBER)))
 
 ;Similar to above, but works when there is no Fonts Widths data.  The
@@ -472 +494 @@
 ;Second value is T if font not found in Fonts Widths.
 (DEFUN PRESS-DEFINE-FONT-FAKE (FAMILY-NAME FACE-NAME POINT-SIZE ROTATION)
-  (IF (ERRSET (FIND-FONT-DATA FAMILY-NAME FACE-NAME POINT-SIZE) NIL)
-      (PRESS-DEFINE-FONT FAMILY-NAME FACE-NAME POINT-SIZE ROTATION)
-      (LET ((WIDTH 633.) (HEIGHT 698.) WIDTH-ARRAY FONT-DESC FONT-NUMBER)
-        (SETQ WIDTH-ARRAY (MAKE-ARRAY NIL 'ART-16B 400))
-        (FILLARRAY WIDTH-ARRAY '(633.))
-        (SETQ FONT-DESC (LIST FAMILY-NAME FACE-NAME POINT-SIZE ROTATION
-                              WIDTH HEIGHT WIDTH-ARRAY))
-        (OR (MEMBER FONT-DESC PRESS-FONT-LIST)
-            (SETQ PRESS-FONT-LIST (NCONC PRESS-FONT-LIST (NCONS FONT-DESC))))
-        (SETQ FONT-NUMBER (FIND-POSITION-IN-LIST-EQUAL FONT-DESC PRESS-FONT-LIST))
-        (AND (
+  (OR (PRESS-LOOKUP-FONT FAMILY-NAME FACE-NAME POINT-SIZE ROTATION)
+      (IF (ERRSET (FIND-FONT-DATA FAMILY-NAME FACE-NAME POINT-SIZE) NIL)
+          (PRESS-DEFINE-FONT FAMILY-NAME FACE-NAME POINT-SIZE ROTATION)
+          (LET ((WIDTH 633.) (HEIGHT 698.) WIDTH-ARRAY FONT-DESC FONT-NUMBER)
+            (SETQ WIDTH-ARRAY (MAKE-ARRAY NIL 'ART-16B 400))
+            (FILLARRAY WIDTH-ARRAY '(633.))
+            (SETQ FONT-DESC (LIST FAMILY-NAME FACE-NAME POINT-SIZE ROTATION
+                                  WIDTH HEIGHT WIDTH-ARRAY))
+            (SETQ PRESS-FONT-LIST (NCONC PRESS-FONT-LIST (NCONS FONT-DESC)))
+            (SETQ FONT-NUMBER (1- (LENGTH PRESS-FONT-LIST)))
+            (AND (
  FONT-NUMBER 16.) (FERROR NIL "Maximum of 16 fonts allowed."))
-        (PROG () (RETURN FONT-NUMBER T)))))
+            (PROG () (RETURN FONT-NUMBER T))))))
+
+;Find position of font in PRESS-FONT-LIST
+(DEFUN PRESS-LOOKUP-FONT (FAMILY FACE POINT-SIZE ROTATION)
+  (DO ((L PRESS-FONT-LIST (CDR L))
+       (I 0 (1+ I)))
+      ((NULL L))
+    (AND (EQUAL FAMILY (CAAR L))
+         (EQUAL FACE (SECOND (CAR L)))
+         (EQUAL POINT-SIZE (THIRD (CAR L)))
+         (EQUAL ROTATION (FOURTH (CAR L)))
+         (RETURN I))))
 
 ;Select a font, by number
@@ -518 +551 @@
 
 (DEFUN PRESS-ENTITY-BCPL-STRING (STRING NBYTES &AUX REAL-LENGTH)
+  (SETQ STRING (STRING STRING))
   (PRESS-ENTITY-BYTE (SETQ REAL-LENGTH (MIN (STRING-LENGTH STRING) (1- NBYTES))))
   (DOTIMES (I REAL-LENGTH)
@@ -525 +559 @@
 
 
+(DEFVAR PRESS-LINE-USE-SPECIAL-OPCODE NIL)
 (DEFVAR NEWVEC-SLOPE-TABLE)
 (DEFVAR NEWVEC-DX-TABLE)
@@ -558 +593 @@
   (PRESS-PUT-PENDING-CHARS)
   (PRESS-MAYBE-NEW-ENTITY)                      ;This should make DPLT work better
-  (COND ((= X0 X1)                              ;Vertical line
+  (COND (PRESS-LINE-USE-SPECIAL-OPCODE
+         (PRESS-SET-CURSOR X0 Y0)
+         (PRESS-ENTITY-BYTE 201)
+         (PRESS-ENTITY-WORD X1)
+         (PRESS-ENTITY-WORD Y1))         
+        ((= X0 X1)                              ;Vertical line
          (PRESS-SET-CURSOR (- X0 (// LINE-WIDTH 2)) (MIN Y0 Y1))        ;Lower left corner
          (PRESS-SHOW-RECT LINE-WIDTH DY))
@@ -673 +713 @@
 ;;;; Print a file
 
-(DEFUN PRINT-FILE (FILE-NAME &OPTIONAL (FONT-NAME "TIMESROMAN")
+(DEFUN PRINT-PRESS-FILE (FILE-NAME &REST OPTIONS)
+  (WITH-OPEN-FILE (INPUT-STREAM FILE-NAME)
+    (WITH-OPEN-STREAM (OUTPUT-STREAM (BIND-PRESS-VARIABLES
+                                       (MULTIPLE-VALUE-BIND (NIL NIL NIL NIL NIL
+                                                             HOST-ADDRESS)
+                                           (PRESS-DECODE-OPTIONS OPTIONS)
+                                         (PRESS-OPEN-EFTP-STREAM HOST-ADDRESS))))
+      (STREAM-COPY-UNTIL-EOF INPUT-STREAM OUTPUT-STREAM)
+      (CLOSE OUTPUT-STREAM)
+      (FUNCALL OUTPUT-STREAM ':SEND-IF-HANDLES ':TRUENAME))))
+
+(DEFUN PRINT-FILE (FILE-NAME &REST OPTIONS)
+  (WITH-OPEN-FILE (STREAM FILE-NAME '(:READ))
+    (LEXPR-FUNCALL #'PRINT-FROM-STREAM
+                   STREAM (FUNCALL STREAM ':TRUENAME) OPTIONS)))
+
+(DEFUN SPOOL-FILE (FILE-NAME &REST OPTIONS)
+  (WITH-OPEN-FILE (STREAM FILE-NAME '(:READ))
+    (LEXPR-FUNCALL #'PRINT-FROM-STREAM
+                   STREAM (FUNCALL STREAM ':TRUENAME) ':SPOOL T OPTIONS)))
+
+(DEFUN PRINT-FROM-STREAM (INPUT-STREAM FILE-NAME &REST OPTIONS
+                          &AUX CREATION-DATE FONT-NAME FACE-NAME FONT-SIZE PAGE-HEADINGS
+                               N-COPIES HOST-ADDRESS)
+  (DECLARE (SPECIAL FILE-NAME CREATION-DATE))
+  (BIND-PRESS-VARIABLES
+    (MULTIPLE-VALUE (FONT-NAME FACE-NAME FONT-SIZE PAGE-HEADINGS N-COPIES HOST-ADDRESS)
+      (PRESS-DECODE-OPTIONS OPTIONS))
+    (IF (MEMQ ':CREATION-DATE (FUNCALL INPUT-STREAM ':WHICH-OPERATIONS))
+        (SETQ CREATION-DATE (FUNCALL INPUT-STREAM ':CREATION-DATE))
+        (SETQ CREATION-DATE (TIME:GET-UNIVERSAL-TIME)))
+    (SETQ CREATION-DATE (TIME:PRINT-UNIVERSAL-TIME CREATION-DATE NIL))
+    (IF PAGE-HEADINGS
+        (SETQ PRESS-END-PAGE-HOOK
+              #'(LAMBDA ()
+                  (FORMAT T "~D " PRESS-PAGE-NUMBER)
+                  (PRESS-SET-CURSOR 0 DOVER-Y0)
+                  (PRESS-STRING (FORMAT NIL "~A~10X~A" FILE-NAME CREATION-DATE))
+                  (PRESS-SET-CURSOR 15000. DOVER-Y0)
+                  (PRESS-STRING (FORMAT NIL "Page ~D" PRESS-PAGE-NUMBER))))
+        (SETQ PRESS-END-PAGE-HOOK
+              #'(LAMBDA () (FORMAT T "~D " PRESS-PAGE-NUMBER))))
+    (FORMAT T "~&~A:  " FILE-NAME)
+    (UNWIND-PROTECT
+      (PROGN (PRESS-START-FILE HOST-ADDRESS)
+             (AND PRESS-INTERPRET-XGP-ESCAPE
+                 (PRESS-XGP-HEADER-PAGE INPUT-STREAM))
+             (PRESS-START-PAGE)
+             (PRESS-SELECT-FONT (IF PRESS-INTERPRET-XGP-ESCAPE 0
+                                    (PRESS-DEFINE-FONT FONT-NAME FACE-NAME FONT-SIZE 0)))
+             (DO ((CH))
+                 ((NULL (SETQ CH (FUNCALL INPUT-STREAM ':TYI))))
+               (IF (AND PRESS-INTERPRET-XGP-ESCAPE (= CH 177))
+                   (PRESS-XGP-ESCAPE INPUT-STREAM)
+                   (PRESS-CHAR CH)))
+             (PRESS-END-PAGE)
+             (PRESS-END-FILE FILE-NAME CREATION-DATE N-COPIES
+                             (COND ((AND FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST
+                                         (NOT (EQUAL FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST
+                                                     "")))
+                                    (FORMAT NIL "~A (~A)" USER-ID
+                                            FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST))
+                                   (T USER-ID))))
+      (AND PRESS-EFTP-STREAM
+           (NOT (STRINGP PRESS-EFTP-STREAM))
+           (FUNCALL PRESS-EFTP-STREAM ':CLOSE ':ABORT)))))
+
+(DEFUN PRESS-DECODE-OPTIONS (OPTIONS &AUX (FONT-NAME "LPT")
                              (FACE-NAME "")
-                             (FONT-SIZE 10.)
+                             (FONT-SIZE 8)
                              (PAGE-HEADINGS T)
                              (N-COPIES 1)
-                             (SEND-TO-MOONS-ALTO-P NIL)
-                             (HOST-ADDRESS DOVER-ADDRESS)
-                             &AUX INPUT-STREAM (PRESS-USE-EFTP PRESS-USE-EFTP))
-  (AND SEND-TO-MOONS-ALTO-P (SETQ PRESS-USE-EFTP T))
-  (UNWIND-PROTECT 
-    (LOCAL-DECLARE ((SPECIAL FILE-NAME CREATION-DATE))
-      (SETQ INPUT-STREAM (OPEN FILE-NAME ':READ))
-      (LET ((FILE-NAME (FUNCALL INPUT-STREAM ':GET ':UNIQUE-ID))
-            (CREATION-DATE (FORMAT NIL "~A ~A" (FUNCALL INPUT-STREAM ':GET ':CREATION-DATE)
-                                   (FUNCALL INPUT-STREAM ':GET ':CREATION-TIME)))
-            (PRESS-END-PAGE-HOOK
-              (IF PAGE-HEADINGS
-                  #'(LAMBDA ()
-                      (FORMAT T " page ~D " PRESS-PAGE-NUMBER)
-                      (PRESS-SET-CURSOR 0 DOVER-Y0)
-                      (PRESS-STRING (FORMAT NIL "~A~10X~A" FILE-NAME CREATION-DATE))
-                      (PRESS-SET-CURSOR 15000. DOVER-Y0)
-                      (PRESS-STRING (FORMAT NIL "Page ~D" PRESS-PAGE-NUMBER)))
-                  #'(LAMBDA ()
-                      (FORMAT T " page ~D " PRESS-PAGE-NUMBER)))))
-        (OR SEND-TO-MOONS-ALTO-P (STRINGP HOST-ADDRESS) (PRINT-DOVER-STATUS))
-        (PRESS-START-FILE (IF SEND-TO-MOONS-ALTO-P 926-ALTO-ADDRESS HOST-ADDRESS))
-        (PRESS-START-PAGE)
-        (PRESS-SELECT-FONT (PRESS-DEFINE-FONT FONT-NAME FACE-NAME FONT-SIZE 0))
-        (DO ((CH (FUNCALL INPUT-STREAM ':TYI) (FUNCALL INPUT-STREAM ':TYI)))
-            ((NULL CH))
-          (PRESS-CHAR CH))
-        (PRESS-END-PAGE)
-        (PRESS-END-FILE FILE-NAME CREATION-DATE N-COPIES)))
-    (CLOSE INPUT-STREAM)))
-
-;Spool a file via MC's spooler
-(DEFUN SPOOL-FILE (FILE-NAME &OPTIONAL (FONT-NAME "TIMESROMAN")
-                             (FACE-NAME "")
-                             (FONT-SIZE 10.)
-                             (PAGE-HEADINGS T)
-                             (N-COPIES 1)
-                             (FILE (FORMAT NIL "MC:.DOVR.;~A >" USER-ID)))
-  (PRINT-FILE FILE-NAME FONT-NAME FACE-NAME FONT-SIZE PAGE-HEADINGS N-COPIES NIL FILE))
-
+                             (HOST-ADDRESS DOVER-ADDRESS))
+  ;; Special variables are just set rather than returned
+  (DECLARE (RETURN-LIST FONT-NAME FACE-NAME FONT-SIZE PAGE-HEADINGS N-COPIES HOST-ADDRESS))
+  (DO ((O OPTIONS (CDDR O)))
+      ((NULL O))
+    (SELECTQ (CAR O)
+      (:FONT-NAME (SETQ FONT-NAME (CADR O)))
+      (:FACE-NAME (SETQ FACE-NAME (CADR O)))
+      (:FONT-SIZE (SETQ FONT-SIZE (CADR O)))
+      (:FONT (MULTIPLE-VALUE (FONT-NAME FACE-NAME FONT-SIZE)
+               (DECODE-FONT-NAME (CADR O))))
+      (:PAGE-HEADINGS (SETQ PAGE-HEADINGS (CADR O)))
+      (:COPIES (SETQ N-COPIES (CADR O)))
+      (:HOST-ADDRESS (SETQ PRESS-USE-EFTP T
+                           HOST-ADDRESS (CADR O)))
+      (:FILE (SETQ HOST-ADDRESS (CADR O)
+                   PRESS-USE-EFTP NIL))
+      (:SPOOL (SETQ HOST-ADDRESS (FORMAT NIL "MC: .DOVR.; ~A >" USER-ID)
+                    PRESS-USE-EFTP NIL))
+      (:EFTP (SETQ HOST-ADDRESS DOVER-ADDRESS
+                   PRESS-USE-EFTP T))
+      (:XGP (SETQ PRESS-INTERPRET-XGP-ESCAPE T
+                  PAGE-HEADINGS NIL))
+      (OTHERWISE (FERROR NIL "~S is an unknown keyword" (CAR O)))))
+  (VALUES FONT-NAME FACE-NAME FONT-SIZE PAGE-HEADINGS N-COPIES HOST-ADDRESS))
+
+(DEFUN DECODE-FONT-NAME (STRING &AUX IDX1 IDX2 (IBASE 10.))
+  (DECLARE (RETURN-LIST FAMILY FACE SIZE))
+  (OR (SETQ IDX1 (STRING-REVERSE-SEARCH-SET '(#/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9)
+                                            STRING))
+      (FERROR NIL "No point size in ~A" STRING))
+  (SETQ IDX2 (1+ (STRING-REVERSE-SEARCH-NOT-SET '(#/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9)
+                                                STRING IDX1)))
+  (VALUES (SUBSTRING STRING 0 IDX2)
+          (SUBSTRING STRING (1+ IDX1))
+          (READ-FROM-STRING (SUBSTRING STRING IDX2 (1+ IDX1)))))
+
+;;; XGP support
+(DEFUN PRINT-XGP-FILE (FILE-NAME &REST OPTIONS)
+  (WITH-OPEN-FILE (STREAM FILE-NAME '(:READ :RAW :SUPER-IMAGE))
+    (LEXPR-FUNCALL #'PRINT-FROM-STREAM
+                   (LET-CLOSED ((FILE-STREAM STREAM))
+                     #'XGP-FILE-STREAM)
+                   (FUNCALL STREAM ':TRUENAME) ':XGP T OPTIONS)))
+
+(DEFVAR XGP-STREAM-RAW-P NIL)
+
+;;; This extra level of stream is necessary, since sometimes we want character set conversion,
+;;; as when reading text, and other times not, as when reading arguments.
+(DEFUN XGP-FILE-STREAM (OP &REST ARGS)
+  (DECLARE (SPECIAL FILE-STREAM))
+  (SELECTQ OP
+    (:WHICH-OPERATIONS '(:TYI :TRUENAME :CREATION-DATE))
+    (:TYI
+     (IF XGP-STREAM-RAW-P (FUNCALL FILE-STREAM ':TYI)
+         (DO ((CH)) (NIL)
+           (SETQ CH (FUNCALL FILE-STREAM ':TYI))
+           (SELECTQ CH
+             (11 (RETURN #\TAB))
+             (12 )
+             (14 (RETURN #\FF))
+             (15 (RETURN #\CR))
+             (OTHERWISE (RETURN CH))))))
+    (:LINE-IN (STREAM-DEFAULT-HANDLER #'XGP-FILE-STREAM OP (CAR ARGS) (CDR ARGS)))
+    (OTHERWISE (LEXPR-FUNCALL FILE-STREAM OP ARGS))))
+
+(DEFCONST XGP-DOTS-PER-INCH 200.)
+
+(DEFMACRO XGP-TO-MICAS (X)
+  `(// (* ,X 2540.) XGP-DOTS-PER-INCH))
+
+(DEFUN PRESS-XGP-HEADER-PAGE (INPUT-STREAM &AUX LEFT-MARGIN TOP-MARGIN BOTTOM-MARGIN)
+  (SETQ LEFT-MARGIN 2540.                       ;Closer to the xgp's values
+        TOP-MARGIN (// (* 2540. 2) 3)
+        BOTTOM-MARGIN TOP-MARGIN)                      
+  (DO ((CH)) (NIL)
+    (SELECTQ (SETQ CH (FUNCALL INPUT-STREAM ':TYI))
+      (#\FORM (RETURN NIL))
+      (#\CR)
+      (#/;
+       (LET* ((LINE (FUNCALL INPUT-STREAM ':LINE-IN))
+              (IDX (STRING-SEARCH-CHAR #\SP LINE))
+              (IBASE 10.))
+         (SELECTOR (SUBSTRING LINE 0 (PROG1 IDX (AND IDX (INCF IDX)))) STRING-EQUAL
+;          ("autcut")
+           ("botmar"
+            (SETQ BOTTOM-MARGIN (XGP-TO-MICAS (READ-FROM-STRING LINE NIL IDX))))
+;          ("delete")
+           ("dfont"
+            (SETQ PRESS-XGP-FONT-LIST
+                  (LOOP FOR I = IDX THEN (1+ J)
+                        FOR J = (STRING-SEARCH-CHAR #/, LINE I)
+                        COLLECT (MULTIPLE-VALUE-BIND (FAMILY FACE SIZE)
+                                    (DECODE-FONT-NAME (SUBSTRING LINE I J))
+                                  (PRESS-DEFINE-FONT FAMILY FACE SIZE 0))
+                        WHILE J)))
+           ("ffcut")
+           ("lftmar"
+            (SETQ LEFT-MARGIN (XGP-TO-MICAS (READ-FROM-STRING LINE NIL IDX))))
+;          ("list")
+           ("lsp"
+            (SETQ PRESS-INTERLINE-SPACING (XGP-TO-MICAS (READ-FROM-STRING LINE NIL IDX))))
+           ("rgtmar")
+           ("skip")
+           ("squish")
+           ("topmar"
+            (SETQ TOP-MARGIN (XGP-TO-MICAS (READ-FROM-STRING LINE NIL IDX))))
+           ("vsp")
+           (OTHERWISE (FERROR NIL "Unknown line ~A in XGP preamble" LINE)))))
+      (OTHERWISE
+       (FERROR NIL "Unknown character in XGP preamble ~C" CH))))
+  (SETQ DOVER-X0 LEFT-MARGIN
+        DOVER-Y1 (- (* 11. 2540.) TOP-MARGIN BOTTOM-MARGIN PRESS-INTERLINE-SPACING)
+        DOVER-Y2 BOTTOM-MARGIN))
+
+(DEFUN PRESS-XGP-ESCAPE (INPUT-STREAM &AUX (XGP-STREAM-RAW-P T) CH)
+  (SELECTQ (SETQ CH (FUNCALL INPUT-STREAM ':TYI))
+    (1 (PRESS-XGP-ESCAPE-1 INPUT-STREAM))
+    (2 (PRESS-XGP-ESCAPE-2 INPUT-STREAM))
+    (3 (PRESS-XGP-ESCAPE-3 INPUT-STREAM))
+    (4 (PRESS-XGP-ESCAPE-4 INPUT-STREAM))
+    (OTHERWISE (PRESS-CHAR CH))))
+
+(DEFUN PRESS-XGP-ESCAPE-1 (INPUT-STREAM &AUX CH)
+  (SETQ CH (FUNCALL INPUT-STREAM ':TYI))
+  (IF (< CH 20)
+      (PRESS-SELECT-FONT (NTH CH PRESS-XGP-FONT-LIST))
+      (SELECTQ CH
+        (40 (PRESS-XGP-SET-COLUMN INPUT-STREAM))
+        (41 (PRESS-XGP-UNDERSCORE INPUT-STREAM))
+        (42 (PRESS-XGP-LINE-SPACE INPUT-STREAM))
+        (43 (PRESS-XGP-BASELINE-ADJUST INPUT-STREAM))
+        (44 (PRESS-XGP-PRINT-PAGE-NUMBER INPUT-STREAM))
+        (45 (PRESS-XGP-SPECIFY-HEADING INPUT-STREAM))
+        (46 (PRESS-XGP-START-UNDERSCORE INPUT-STREAM))
+        (47 (PRESS-XGP-END-UNDERSCORE INPUT-STREAM))
+        (50 (PRESS-XGP-SET-INTERCHAR-SPACING INPUT-STREAM))
+        (51 (PRESS-XGP-END-SPECIFIED-WIDTH-UNDERSCORE INPUT-STREAM))
+        (52 (PRESS-XGP-RELATIVE-BASELINE-ADJUST INPUT-STREAM))
+        (53 (PRESS-XGP-RELATIVE-UNDERSCORE INPUT-STREAM))
+        (OTHERWISE (FERROR NIL "Unknown XGP escape ~O" CH)))))
+
+;;; Sign extended version of above
+(DEFUN PRESS-XGP-ONE-BYTE-ARG (INPUT-STREAM)
+  (LET ((CH (FUNCALL INPUT-STREAM ':TYI)))
+    (IF (BIT-TEST 100 CH) (- 200 CH) CH)))
+
+(DEFUN PRESS-XGP-TWO-BYTE-ARG (INPUT-STREAM)
+  (DPB (FUNCALL INPUT-STREAM ':TYI) 0707 (FUNCALL INPUT-STREAM ':TYI)))
+
+(DEFUN PRESS-XGP-THREE-BYTE-ARG (INPUT-STREAM)
+  (DPB (FUNCALL INPUT-STREAM ':TYI) 1607
+       (DPB (FUNCALL INPUT-STREAM ':TYI) 0707 (FUNCALL INPUT-STREAM ':TYI))))
+
+(DEFUN PRESS-XGP-SET-COLUMN (INPUT-STREAM)
+  (PRESS-SET-CURSOR (XGP-TO-MICAS (PRESS-XGP-TWO-BYTE-ARG INPUT-STREAM)) PRESS-Y))
+
+(DEFUN PRESS-XGP-UNDERSCORE (INPUT-STREAM)
+  (PRESS-XGP-DO-UNDERSCORE (- PRESS-Y (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM)))
+                           PRESS-X (PRESS-XGP-TWO-BYTE-ARG INPUT-STREAM) 2.))
+
+(DEFUN PRESS-XGP-LINE-SPACE (INPUT-STREAM)
+  (SETQ PRESS-INTERCHAR-SPACING NIL)
+  (PRESS-SET-CURSOR PRESS-X (- PRESS-Y (XGP-TO-MICAS (FUNCALL INPUT-STREAM ':TYI)))))
+
+(DEFUN PRESS-XGP-BASELINE-ADJUST (INPUT-STREAM)
+  (SETQ PRESS-INTERCHAR-SPACING NIL)
+  (PRESS-SET-CURSOR
+    (SETQ PRESS-BASELINE-Y (+ PRESS-Y (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM))))
+    PRESS-X))
+
+(DEFUN PRESS-XGP-PRINT-PAGE-NUMBER (IGNORE)
+  (PRESS-STRING (FORMAT NIL "~D" PRESS-PAGE-NUMBER)))
+
+(DEFUN PRESS-XGP-SPECIFY-HEADING (INPUT-STREAM)
+  (LET* ((LENGTH (FUNCALL INPUT-STREAM ':TYI))
+         (STRING (MAKE-ARRAY LENGTH ':TYPE 'ART-STRING)))
+    (LOOP FOR I FROM 0 BELOW LENGTH
+          DO (ASET (FUNCALL INPUT-STREAM ':TYI) STRING I))
+    (SETQ PRESS-END-PAGE-HOOK (LET-CLOSED ((STRING STRING))
+                                #'(LAMBDA ()
+                                    (FORMAT T "~D " PRESS-PAGE-NUMBER)
+                                    (WITH-INPUT-FROM-STRING (INPUT-STREAM STRING)
+                                      (DO ((CH))
+                                          ((NULL (SETQ CH (FUNCALL INPUT-STREAM ':TYI))))
+                                        (IF (AND PRESS-INTERPRET-XGP-ESCAPE (= CH 177))
+                                            (PRESS-XGP-ESCAPE INPUT-STREAM)
+                                            (PRESS-CHAR CH)))))))))
+
+(DEFUN PRESS-XGP-START-UNDERSCORE (IGNORE)
+  (SETQ PRESS-XGP-UNDERLINE-START-X PRESS-X))
+
+(DEFUN PRESS-XGP-END-UNDERSCORE (INPUT-STREAM)
+  (PRESS-XGP-DO-UNDERSCORE (- PRESS-BASELINE-Y
+                              (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM)))
+                           PRESS-XGP-UNDERLINE-START-X
+                           PRESS-X 2.))
+
+(DEFUN PRESS-XGP-SET-INTERCHAR-SPACING (INPUT-STREAM)
+  (SETQ PRESS-INTERCHAR-SPACING (XGP-TO-MICAS (FUNCALL INPUT-STREAM ':TYI))))
+
+(DEFUN PRESS-XGP-END-SPECIFIED-WIDTH-UNDERSCORE (INPUT-STREAM)
+  (LET ((WIDTH (FUNCALL INPUT-STREAM ':TYI)))
+    (PRESS-XGP-DO-UNDERSCORE (- PRESS-BASELINE-Y
+                                (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM)))
+                             PRESS-XGP-UNDERLINE-START-X
+                             PRESS-X WIDTH)))
+
+(DEFUN PRESS-XGP-RELATIVE-BASELINE-ADJUST (INPUT-STREAM)
+  (PRESS-SET-CURSOR
+    (SETQ PRESS-BASELINE-Y (+ PRESS-BASELINE-Y
+                              (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM))))
+    PRESS-X))
+
+(DEFUN PRESS-XGP-RELATIVE-UNDERSCORE (INPUT-STREAM)
+  (PRESS-XGP-DO-UNDERSCORE (- PRESS-BASELINE-Y
+                              (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM)))
+                           PRESS-X (PRESS-XGP-TWO-BYTE-ARG INPUT-STREAM) 2.))
+
+(DEFUN PRESS-XGP-DO-UNDERSCORE (TOP-Y X-START X-END THICKNESS &AUX (OX PRESS-X) (OY PRESS-Y))
+  (PRESS-SET-CURSOR X-START (- TOP-Y THICKNESS))
+  (PRESS-ENTITY-BYTE 376)       ;Show-rectangle
+  (PRESS-ENTITY-WORD (- X-END X-START))         ;Width
+  (PRESS-ENTITY-WORD (XGP-TO-MICAS THICKNESS))  ;Thickness
+  (PRESS-SET-CURSOR OX OY))
+
+(DEFUN PRESS-XGP-ESCAPE-2 (INPUT-STREAM)
+  (PRESS-SET-CURSOR (+ PRESS-X (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM)))
+                    PRESS-Y))
+
+(DEFUN PRESS-XGP-ESCAPE-3 (IGNORE)
+  (FERROR NIL "XGP escape 3 not implemented"))
+
+(DEFUN PRESS-XGP-ESCAPE-4 (IGNORE)
+  (FERROR NIL "XGP escape 4 not implemented"))
 
 ;;;;Font sampling
@@ -724 +1026 @@
 ; rotation is optional and defaults to 0
 (DEFUN SAMPLE-FONTS (FONT-LIST &OPTIONAL (UPPER-HALF NIL)
-                                         (SEND-TO-MOONS-ALTO-P NIL)
                                          (HOST-ADDRESS DOVER-ADDRESS)
-                               &AUX (PRESS-USE-EFTP PRESS-USE-EFTP) FOO CH)
-  (AND SEND-TO-MOONS-ALTO-P (SETQ PRESS-USE-EFTP T))
-  (OR SEND-TO-MOONS-ALTO-P (STRINGP HOST-ADDRESS) (PRINT-DOVER-STATUS))
-  (PRESS-START-FILE (IF SEND-TO-MOONS-ALTO-P 926-ALTO-ADDRESS HOST-ADDRESS))
+                               &AUX FOO CH)
+ (BIND-PRESS-VARIABLES
+  (PRESS-START-FILE HOST-ADDRESS)
   (LET ((LABEL-FONT (PRESS-DEFINE-FONT "TIMESROMAN" "" 10. 0)) THIS-FONT NOT-IN-FONTS-WIDTHS)
     (DO ((L FONT-LIST (CDR L))
@@ -739 +1039 @@
       (COND ((= I 16.)                          ;Got to make a new file
              (PRESS-END-FILE "Font samples" "")
-             (RETURN (SAMPLE-FONTS L UPPER-HALF SEND-TO-MOONS-ALTO-P))))
+             (RETURN (SAMPLE-FONTS L UPPER-HALF))))
       (PRESS-START-PAGE)
       (MULTIPLE-VALUE (THIS-FONT NOT-IN-FONTS-WIDTHS)
@@ -775 +1075 @@
       (PRESS-CHAR-SEQ #/! #/?)
       (PRESS-CHAR-SEQ #/[ #/_)
-      (PRESS-CHAR-SEQ #/{ #/‡ #\CR)
+      (PRESS-CHAR-SEQ #/{ #/ #\CR)
       (PRESS-CHAR-SEQ #/ #/)
       (PRESS-SET-CURSOR 0 4150.)
@@ -794 +1094 @@
       (PRESS-SET-CURSOR 8750. PRESS-Y)
       (PRESS-STRING "             (T (CONS (CAR X) (APPEND (CDR X) Y)))))")
-      (PRESS-END-PAGE))))
+      (PRESS-END-PAGE)))))
 
 (DEFUN PRESS-CHAR-SEQ (FIRST LAST &OPTIONAL EXTRA)
@@ -860 +1160 @@
 
   (TEMPLATE || 64.) ))
+
+;; Read in all fonts from FONTS;DOVER FONTS
+(DEFUN COMPUTE-DOVER-FONTS (&AUX NAME FACE POINT ROT TEM ANSWER (IBASE 10.))
+  (WITH-OPEN-FILE (I "AI: FONTS; DOVER FONTS")
+    (DO ((LINE) (EOF)) (NIL)
+      (MULTIPLE-VALUE (LINE EOF)
+        (FUNCALL I ':LINE-IN))
+      (AND EOF
+           (OR (NULL LINE) (EQUAL LINE ""))
+           (RETURN (NREVERSE ANSWER)))
+      (SETQ TEM (STRING-SEARCH-CHAR #/, LINE)
+            NAME (INTERN (SUBSTRING LINE 7 TEM) "PRESS")
+            TEM (+ TEM 2)
+            FACE (COND ((STRING-EQUAL LINE "MR" TEM 0 (+ TEM 2) 2) '||)
+                       ((STRING-EQUAL LINE "MI" TEM 0 (+ TEM 2) 2) 'I)
+                       ((STRING-EQUAL LINE "BR" TEM 0 (+ TEM 2) 2) 'B)
+                       ((STRING-EQUAL LINE "BI" TEM 0 (+ TEM 2) 2) 'BI)
+                       (T (FERROR NIL "Parsing error in fonts file.")))
+            TEM (1+ (STRING-SEARCH-CHAR #/( LINE TEM))
+            POINT (READ-FROM-STRING LINE 'SI:NO-EOF-OPTION TEM)
+            TEM (+ (STRING-SEARCH-CHAR #/: LINE TEM) 2)
+            ROT (READ-FROM-STRING LINE 'SI:NO-EOF-OPTION TEM))
+      (PUSH (LIST NAME FACE POINT ROT) ANSWER))))
+
 
 (COMMENT ;hacks
@@ -887 +1211 @@
   (PRESS-END-FILE "Lines" ""))
 );comment
+
+;;; ZWEI interface
+;;; should have a way of setting this stuff
+(DEFVAR DIRED-PRINT-OPTIONS NIL)
+
+(DEFUN (:DOVER :DIRED-PRINT-FUNCTION) (PATHNAME TYPE)
+  (SELECTQ TYPE
+    (:SUDS-PLOT
+     (AND (NOT (FBOUNDP ':DPLT-PRINT-FILE))
+          (LOAD "SYS: IO1; DPLT PKG >")
+          (PKG-LOAD 'DPLT '(:NOCONFIRM)))
+     (:DPLT-PRINT-FILE PATHNAME)
+     T)
+    (:XGP
+     (LEXPR-FUNCALL #'PRINT-XGP-FILE PATHNAME DIRED-PRINT-OPTIONS))
+    (:TEXT (LEXPR-FUNCALL #'PRINT-FILE PATHNAME DIRED-PRINT-OPTIONS))
+    (:PRESS (LEXPR-FUNCALL #'PRINT-PRESS-FILE PATHNAME DIRED-PRINT-OPTIONS))
+    (OTHERWISE (FORMAT NIL "I don't know how to print files of type ~A" TYPE))))
+

trunk/lisp/lmio1/promp.lisp

@@ -3 +3 @@
 ;;; Routines to hack the prom programmer
 ;;; Type "Select F1 Start" on the "System 19" to put it in remote mode
-;;; This program operates at 300 baud
+;;; This program operates at 300 baud at MIT but at 1200 baud at Symbolics.
+;;; Other sites should edit in whatever speed they prefer.
 
 ;;; Modified 8/8/79 by Moon to use the IOB serial interface
@@ -73 +74 @@
   (OR (BOUNDP 'PROGRAMMER-STREAM)
       (SETQ PROGRAMMER-STREAM (SI:MAKE-SERIAL-STREAM
-                                ':PARITY NIL ':NUMBER-OF-DATA-BITS 8 ':BAUD 300.)))
+                                ':PARITY NIL
+                                ':NUMBER-OF-DATA-BITS 8
+                                ':BAUD #+MIT 300. #+SYM 1200.)))
   (FUNCALL PROGRAMMER-STREAM ':CLEAR-INPUT)
   (FUNCALL PROGRAMMER-STREAM ':TYO 33)          ;This resets the programmer
@@ -106 +109 @@
 (DEFUN PROGRAMMER-READ-RAM (&OPTIONAL (ARRAY (MAKE-ARRAY NIL 'ART-8B
                                                          (1+ PROGRAMMER-DEVICE-WORD-LIMIT))))
+  (PROGRAMMER-RESET)
   (MULTIPLE-VALUE-BIND (IGNORE FAILURE)
       (PROGRAMMER-COMMAND "83A" NIL)
@@ -111 +115 @@
          (FERROR NIL "Cannot set transfer format"))
     (PROGRAMMER-COMMAND "O" 'NONE)
-    (DO ((BYTE-COUNT) (PROGRAMMER-CHECKSUM 0 0) (ADR 0) (CS) (RECORD-TYPE))
+    (DO ((BYTE-COUNT) (PROGRAMMER-CHECKSUM 0 0) (ADR 0) (CS) (RECORD-TYPE)
+         (ARRAY-LEN (ARRAY-LENGTH ARRAY)))
         (())
       ;Start character is a colon
@@ -120 +125 @@
       (SELECTQ RECORD-TYPE
         (00                                     ;Data record
+         (COND ((
+ ADR ARRAY-LEN)
+                ;; With the new software, it seems that the programmer can overrun the array
+                (FORMAT T "~&Programmer sending too much data, resetting.")
+                (PROGRAMMER-RESET)
+                (RETURN NIL)))
          (DOTIMES (I BYTE-COUNT)
-           (ASET (HEX-READ-BYTE) ARRAY (+ ADR I)))
+           (LET ((BYTE (HEX-READ-BYTE)))
+             (AND  (< (+ ADR I) ARRAY-LEN)
+                   (ASET BYTE ARRAY (+ ADR I)))))
          (SETQ CS (LOGAND (- PROGRAMMER-CHECKSUM) 377))
          (COND (( (SETQ RECORD-TYPE (HEX-READ-BYTE)) CS)
@@ -243 +256 @@
      (PROGRAMMER-COMMAND "P"))
    (COND (FAIL
-          (FORMAT T "&~Programming failed.")
+          (FORMAT T "~&Programming failed.")
           (RETURN NIL)))
    (FORMAT T "~&Verifying device.")
@@ -318 +331 @@
     (OR FROM (DO () ((PROGRAMMER-PROGRAM-PROM (CAR PROM))))))
   'DONE)
+ 

trunk/lisp/lmio1/reldmp.lisp

@@ -1 @@
-;-*-Mode: Lisp; Package: QFASL-REL-*-
+;-*-Mode: Lisp; Package: QFASL-REL; Lowercase: T-*-
 
 ;Temporary area for data structures used in dumping.
@@ -112 +112 @@
 ;Dump the file property list
 ;as a bunch of defprops to be evaluated at load time.
-(defun dump-file-property-list (file-group-symbol plist)
+(defun dump-file-property-list (generic-pathname plist)
+  (dump-form `(set-generic-pathname-property-list
+                ;; Cannot fasd instances yet.
+                ,(funcall generic-pathname ':string-for-printing)
+                ,plist)))
+
+(defun set-generic-pathname-property-list (generic-pathname-string plist &aux pathname)
+  (setq pathname (funcall (fs:merge-pathname-defaults generic-pathname-string)
+                          ':generic-pathname))
   (do ((l plist (cddr l))) ((null l))
-    (dump-form `(defprop ,file-group-symbol (cadr l) (car l)))))
+    (funcall pathname ':putprop (cadr l) (car l))))
 
 ;Dump a form to be evaluated at load time.

trunk/lisp/lmio1/relld.lisp

@@ -421 +421 @@
                (set form (%p-contents-offset org (setq i (1+ i)))))
               ((= type 2)
-               (prog (tem si:fdefine-file-symbol)
+               (prog (tem si:fdefine-file-pathname)
                      (setq tem (%p-contents-offset org (setq i (1+ i)))
-                           si:fdefine-file-symbol (%p-contents-offset org (setq i (1+ i))))
+                           si:fdefine-file-pathname (%p-contents-offset org (setq i (1+ i))))
                      (fset-carefully form tem))))))))
 

trunk/lisp/lmio1/rfontw.lisp

@@ -7 +7 @@
 
 (declare (special font-width-data))
+#Q (declare (setq run-in-maclisp-switch t))
 
 ;Interesting functions:
@@ -12 +13 @@
 ;       loads up the file.  Takes an optional argument of the filename
 ;       of the widths file (defaults to FONTS; FONTS WIDTHS).
+;       If a second optional argument is supplied, it is a list of
+;       lists (family-name face-name point-size) and only those
+;       specific fonts are loaded, to avoid running out of pdp-10
+;       address space.
 ;       Merges with pre-existing contents of FONT-WIDTH-DATA (set it
 ;       to NIL first if you want to flush the old data.)
@@ -47 +52 @@
 
 
+#M (eval-when (compile eval)
+        (defmacro with-open-file ((var filename options) . body)
+                  `(let ((,var (open ,filename ,options)))
+                     ,@body
+                     (close ,var))))
+
 (declare (special widths-file code-alist #M widths-file-next-word))
 
@@ -55 +66 @@
 #M (declare (fixnum (next-word) (widths-file-pos) i j k m n wd))
 
-(eval-when (compile eval)
+(eval-when (compile eval #q load)
 (defmacro high-byte (word)
   `(lsh ,word -8))
@@ -74 +85 @@
   #Q (funcall widths-file ':tyi "Unexpected EOF on widths file"))
 
-
 (defun widths-file-pos ()
    #M (- (* 2 (filepos widths-file))
@@ -88 +98 @@
 
              
-(defun bcpl-string (n) ;n = max-length-including-header-byte and is even
+(defun bcpl-string (n widths-file) ;n = max-length-including-header-byte and is even
   (let ((wd (next-word)))
       (do ((chlist #M nil #Q (make-array nil 'art-string (high-byte wd)))
@@ -113 +123 @@
       (list 'code code)))
 
-(defun decode-face (face-code)
-  (declare (fixnum face-code))
-  (let ((l nil))
+;Normal face codes are || for normal, I for italic, B for bold, etc.
+;These are strings rather than symbols on the Lisp machine.
+;Alternatively the face code can be a list of the normal code,
+;the CMU character-set-convention code, and the TEX logical size code.
+(defun decode-face (face-code2)
+  (declare (fixnum face-code2))
+  (let ((l nil)
+        (res nil)
+        (face-code (\ face-code2 18.))
+        (cmu-bullshit (\ (// face-code2 18.) 3))
+        (tex-bullshit (if (< face-code2 54.) -1 (- face-code2 54.))))
+    (declare (fixnum face-code cmu-bullshit tex-bullshit))
     (cond ((> face-code 11.)
            (setq face-code (- face-code 12.))
@@ -133 +152 @@
     (cond ((not (zerop face-code))
            (error '|extra garbage in face-code| face-code)))
- #M (implode l)
- #Q (fillarray (make-array nil 'art-string (length l)) l)))
+    (setq res #M (implode l)
+              #Q (fillarray (make-array (length l) ':type 'art-string) l))
+    (cond ((or (not (zerop cmu-bullshit)) (not (minusp tex-bullshit)))
+           (setq res (list res cmu-bullshit))
+           (or (minusp tex-bullshit)
+               (setq res (nconc res (list tex-bullshit))))))
+    res))
 
 ;Load it up and make the data structure mentioned at front of file
-(defun load-font-widths (&optional (filename '|dsk:fonts;fonts widths|))
-  (let ((widths-file (open filename '(read fixnum)))
-        (code-alist nil)
-        (segment-data nil)
-        (wd 0))
- #M (store (arraycall fixnum widths-file-next-word 0) -1)
-    (setq wd (next-word))
-    ;; Read IXN entries (type 1)
-    (do () ((not (= (lsh wd -12.) 1)))
-      (let ((code (next-word))
-            (name (bcpl-string 20.)))
-        (push (cons code name) code-alist))
-      (setq wd (next-word)))
-    ;; Read WidthIndexEntries (type 4)
-    (do () ((not (= (lsh wd -12.) 4)))
-      (setq wd (next-word))             ;family,,face
-      (push (list (code-to-name (high-byte wd))         ;Family-name
-                  (decode-face (low-byte wd))           ;Face name
-                  (progn (setq wd (next-word))          ;bc,,ec
-                         (high-byte wd))                ;First code
-                  (low-byte wd)                         ;Last code
-                  (next-word)                           ;Size
-                  (next-word)                           ;Rotation
-                  (+ (lsh (next-word) 16.) (next-word)) ;Segment SA
-                  (+ (lsh (next-word) 16.) (next-word)));Segment Len
-            segment-data)
-      (setq wd (next-word)))
-    ;; Now should have type-0 entry (end of index)
-    (or (zerop (lsh wd -12.))
-        (error '|Bullshit in file where type 0 IX expected| wd))
-    ;; Now read out the WidthSegments, which should follow
-    ;; immediately with no gaps.  Sort segments by SA
-    ;; Hmm, now it seems gaps are allowed, so we skip them.
-    (setq segment-data (sort segment-data
-                             #'(lambda (x y)
-                                 (< (cadddr (cdddr x)) (cadddr (cdddr y))))))
-    (or (boundp 'font-width-data)
-        (setq font-width-data nil))
-    (do ((segment-data segment-data (cdr segment-data))
-         (seg) (bb) (m 0) (xwidths) (ywidths))
-        ((null segment-data))
-      (setq seg (car segment-data))
-      (let ((gap (- (cadddr (cdddr seg)) (widths-file-pos))))
-        #M (declare (fixnum gap))
-        (cond ((minusp gap) (break file-out-of-phase t)))
-        (dotimes (i gap) (next-word)))
-      (setq bb (list (next-word2) (next-word2) (next-word2) (next-word2)))
-      (setq m (next-word))                              ;Flags
-        ;Note that the documentation on this flags word is wrong!
-      ;; Process X-data
-      (cond ((not (zerop (boole 1 100000 m)))
-             (setq xwidths (next-word)))
-            (t (setq xwidths (*array nil 'fixnum 400))
-               (fillarray xwidths '(-1))        ;Chars not in bc..ec have -1
-               (do ((j (caddr seg) (1+ j))
-                    (k 0))
-                   ((> j (cadddr seg)))
-                 (setq k (next-word))
-                 (and (= k 100000) (setq k -1))
-                 (store (arraycall fixnum xwidths j) k))))
-      ;; Process Y-data
-      (cond ((not (zerop (boole 1 40000 m)))
-             (setq ywidths (next-word)))
-            (t (setq ywidths (*array nil 'fixnum 400))
-               (fillarray xwidths '(-1))        ;Chars not in bc..ec have -1
-               (do ((j (caddr seg) (1+ j))
-                    (k 0))
-                   ((> j (cadddr seg)))
-                 (setq k (next-word))
-                 (and (= k 100000) (setq k -1))
-                 (store (arraycall fixnum ywidths j) k))))
-      ;; Make the data
-      (push (list (car seg) (cadr seg) (car (cddddr seg)) (cadr (cddddr seg))
-                  bb xwidths ywidths)
-            font-width-data))
-    (close widths-file)))
+(defun load-font-widths (&optional filename fonts-desired)
+  (with-open-file (widths-file (or filename '((dsk fonts)fonts widths))
+                               '(read fixnum))
+    (let ((code-alist nil)
+          (segment-data nil)
+       #M (noret t)     ; don't play musical corblk while loading stuff
+          (wd 0))
+      ; guestimate core needed:
+   #M (let ((max-guess (* 3 (lengthf widths-file))))
+        (declare (fixnum max-guess))
+        (and fonts-desired (let ((new-guess (* 800 (length fonts-desired))))
+                             (declare (fixnum new-guess))
+                             (and (< new-guess max-guess)
+                                  (setq max-guess new-guess))))
+        (getsp max-guess))
+   #M (store (arraycall fixnum widths-file-next-word 0) -1)
+      (setq wd (next-word))
+      ;; Read IXN entries (type 1)
+      (do () ((not (= (lsh wd -12.) 1)))
+        (let ((code (next-word))
+              (name (bcpl-string 20. widths-file)))
+          (push (cons code name) code-alist))
+        (setq wd (next-word)))
+      ;; Read WidthIndexEntries (type 4)
+      (do () ((not (= (lsh wd -12.) 4)))
+        (setq wd (next-word))           ;family,,face
+        (push (list (code-to-name (high-byte wd))               ;Family-name
+                    (decode-face (low-byte wd))         ;Face name
+                    (progn (setq wd (next-word))                ;bc,,ec
+                           (high-byte wd))              ;First code
+                    (low-byte wd)                               ;Last code
+                    (next-word)                         ;Size
+                    (next-word)                         ;Rotation
+                    (+ (lsh (next-word) 16.) (next-word))       ;Segment SA
+                    (+ (lsh (next-word) 16.) (next-word)));Segment Len
+              segment-data)
+        (setq wd (next-word)))
+      ;; Now should have type-0 entry (end of index)
+      (or (zerop (lsh wd -12.))
+          (error '|Bullshit in file where type 0 IX expected| wd))
+      ;; Now read out the WidthSegments, which should follow
+      ;; immediately with no gaps.  Sort segments by SA
+      ;; Hmm, now it seems gaps are allowed, so we skip them.
+      ;; Also skip entries for fonts not in fonts-desired if it is non-nil.
+      (setq segment-data (sort segment-data
+                               #'(lambda (x y)
+                                   (< (cadddr (cdddr x)) (cadddr (cdddr y))))))
+      (or (boundp 'font-width-data)
+          (setq font-width-data nil))
+      (do ((segment-data segment-data (cdr segment-data))
+           (seg) (bb) (m 0) (xwidths) (ywidths))
+          ((null segment-data))
+        (setq seg (car segment-data))
+        (let ((gap (- (cadddr (cdddr seg)) (widths-file-pos))))
+          #M (declare (fixnum gap))
+          (cond ((minusp gap) (break file-out-of-phase t)))
+          (dotimes (i gap) (next-word)))
+        (setq bb (list (next-word2) (next-word2) (next-word2) (next-word2)))
+        (setq m (next-word))                            ;Flags
+          ;Note that the documentation on this flags word is wrong!
+        (cond ((or (null fonts-desired)
+                   (loop for f in fonts-desired
+                         thereis (and (equal (car f) (car seg))  ;family
+                                      (equal (cadr f) (cadr seg)) ;face
+                                      (or (zerop (car (cddddr seg))) ;general
+                                          (point-size-equal     ;specific
+                                              (car (cddddr seg)) (caddr f)))
+                                      (zerop (cadr (cddddr seg))) ;no rotation
+                                      )))
+               ;; Process X-data
+               (cond ((not (zerop (boole 1 100000 m)))
+                      (setq xwidths (next-word)))
+                     (t (setq xwidths (*array nil 'fixnum 400))
+                        (fillarray xwidths '(-1))       ;Chars not in bc..ec
+                        (do ((j (caddr seg) (1+ j))
+                             (k 0))
+                            ((> j (cadddr seg)))
+                          (setq k (next-word))
+                          (and (= k 100000) (setq k -1))
+                          (store (arraycall fixnum xwidths j) k))))
+               ;; Process Y-data
+               (cond ((not (zerop (boole 1 40000 m)))
+                      (setq ywidths (next-word)))
+                     (t (setq ywidths (*array nil 'fixnum 400))
+                        (fillarray xwidths '(-1))       ;Chars not in bc..ec
+                        (do ((j (caddr seg) (1+ j))
+                             (k 0))
+                            ((> j (cadddr seg)))
+                          (setq k (next-word))
+                          (and (= k 100000) (setq k -1))
+                          (store (arraycall fixnum ywidths j) k))))
+               ;; Make the data
+               (push (list (car seg) (cadr seg) (car (cddddr seg))
+                           (cadr (cddddr seg)) bb xwidths ywidths)
+                     font-width-data))
+              (t        ;Skip this font
+               ;; Skip X-data
+               (cond ((not (zerop (boole 1 100000 m)))
+                      (next-word))
+                     (t (do ((j (caddr seg) (1+ j)))
+                            ((> j (cadddr seg)))
+                          (next-word))))
+               ;; Skip Y-data
+               (cond ((not (zerop (boole 1 40000 m)))
+                      (next-word))
+                     (t (do ((j (caddr seg) (1+ j)))
+                            ((> j (cadddr seg)))
+                          (next-word))))))))
+ #Q (si:set-file-loaded-id (funcall widths-file ':pathname) (funcall widths-file ':info)
+                           package)
+    ))
 
 ;This will return the entry for the particular size if it
 ;can find it, otherwise the entry for relative size.
+;Errors out if no info found.
 (defun find-font-data (family-name face-name point-size)
+  (or (find-font-data-1 family-name face-name point-size)
+      (error '|No information for font|
+             (list family-name face-name point-size))))
+
+;This will return the entry for the particular size if it
+;can find it, otherwise the entry for relative size.
+;Returns NIL if no info found.
+(defun find-font-data-1 (family-name face-name point-size)
  #Q (setq family-name (string family-name) face-name (string face-name))
     (or (do l font-width-data (cdr l) (null l)
           (and (equal (caar l) family-name)
                (equal (cadar l) face-name)
-               ;(= (// (* (caddar l) 72.) 2540.) point-size)
-               ;The above does not work.  Apparently Xerox just plain is not consistent
-               ;about how many points there are in an inch.  It doesn't help that their
-               ;font documentation is riddled with errors.  So we'll do something extremely
-               ;forgiving.
-               (> (caddar l) (// (- (* point-size 2540.) 1270.) 72.))
-               (< (caddar l) (// (+ (* point-size 2540.) 1270.) 72.))
+               (point-size-equal (caddar l) point-size)
                (zerop (cadddr (car l)))                 ;No rotation
                (return (car l))))
@@ -235 +297 @@
                (zerop (caddar l))
                (zerop (cadddr (car l)))                 ;No rotation
-               (return (car l))))
-        (error '|No information for font|
-               (list family-name face-name point-size))))
+               (return (car l))))))
+
+(defun point-size-equal (internal point-size)
+  (and ;(= (// (* internal 72.) 2540.) point-size)
+       ;The above does not work.  Apparently Xerox just plain is not consistent
+       ;about how many points there are in an inch.  It doesn't help that their
+       ;font documentation is riddled with errors.  So we'll do something
+       ;extremely forgiving.
+       (> internal (// (- (* point-size 2540.) 1270.) 72.))
+       (< internal (// (+ (* point-size 2540.) 1270.) 72.))))
 
 ; (GET-FONT-WIDTH-DATA family-name face-name point-size)
@@ -283 +352 @@
             ((list (// (* (caddr bb) point-size 2540.) 72000.)
                    (// (* (cadddr bb) point-size 2540.) 72000.)))))))
-
-(comment ;This does not even compile!
-(if-for-lispm
-;Read in an AC file as a Lisp machine font.
-(defun load-font (filename &optional family-name face-name point-size)
- (unwind-protect
-  (let ((widths-file (open filename '(read fixnum)))
-        (code-alist nil)
-        (segment-data nil)
-        family-code tem segment
-        (wd 0))
-    (setq wd (next-word))
-    ;; Read IXN entries (type 1)
-    (do () ((not (= (lsh wd -12.) 1)))
-      (let ((code (next-word))
-            (name (bcpl-string 20.)))
-        (push (cons code name) code-alist))
-      (setq wd (next-word)))
-    ;; Find out the code number for the font family to be used,
-    ;; either the specified one or the only one.
-    (cond (family-name (setq family-code (name-to-code family-name)))
-          ((cdr code-alist)
-           (ferror nil "Font dictionary ~A: font family not specified" filename))
-          (t (setq family-code (caar code-alist))))
-    ;; Read Index Entries (type 3) for AC segments.
-    (do () ((not (= (lsh wd -12.) 4)))
-      (setq wd (next-word))             ;family,,face
-      (setq tem
-            (list (high-byte wd)                        ;Family code number.
-                  (decode-face (low-byte wd))           ;Face name
-                  (progn (setq wd (next-word))          ;bc,,ec
-                         (high-byte wd))                ;First code
-                  (low-byte wd)                         ;Last code
-                  (next-word)                           ;Size
-                  (next-word)                           ;Rotation
-                  (+ (lsh (next-word) 16.) (next-word)) ;Segment SA
-                  (+ (lsh (next-word) 16.) (next-word))));Segment Len
-      (next-word) (next-word)                   ;Ignore resolution values.
-      (and (= (car tem) family-code) (push tem segment-data))
-      (setq wd (next-word)))
-    ;; Now should have type-0 entry (end of index)
-    (or (zerop (lsh wd -12.))
-        (error '|Bullshit in file where type 0 IX expected| wd))
-    ;; Now either there should be only one segment or the face code and size
-    ;; should have been specified.
-    (cond (point-size (dolist (seg segment-data)
-                        (and (eq (cadr seg) face-code)
-                             (= (fifth seg) point-size)
-                             (return (setq segment seg)))))
-          ((cdr segment-data)
-           (ferror "Font dictionary ~A: point size not specified" filename))
-          ((setq segment (car segment-data))))
-    (funcall widths-file ':set-pointer (seventh segment))
-    (let ((bc (third segment))
-          (ec (fourth segment))
-          line-height)
-      (setq xwidths (make-array nil art-16b 200))
-      (setq ywidths (make-array nil art-16b 200))
-      (setq box-x-offset (make-array nil art-16b 200))
-      (setq box-y-offset (make-array nil art-16b 200))
-      (setq box-x-size (make-array nil art-16b 200))
-      (setq box-y-size (make-array nil art-16b 200))
-      ;; read in the widths info from the segment.
-      (do ((i bc (1+ i))) ((> i ec))
-        (aset (next-word) xwidths i)
-        (next-word)
-        (aset (next-word) ywidths i)
-        (next-word)
-        (aset (next-word) box-x-offset i)
-        (aset (next-word) box-y-offset i)
-        (aset (next-word) box-x-size i)
-        (aset (next-word) box-y-size i))
-      ;; Ignore the table of offsets to the raster info
-      (do ((i bc (1+ i))) ((>i ec))
-        (next-word))
-      (setq fontname (string-append (code-to-name family-code)
-                                    (format nil "~D" point-size)
-                                    (second segment)))
-      (setq fontname (intern (string-upcase fontname) "FONTS"))
-      (setq fd (fed:make-font-descriptor fed:fd-name fontname))
-      (do ((height 0)
-           (baseline 0)
-           (i bc (1+ i)))
-          ((> i ec)
-           (setq line-height (+ height baseline))
-           (setf (fed:fd-line-spacing fd) line-height)
-           (setf (fed:fd-blinker-height fd) line-height)
-           (setf (fed:fd-baseline fd) baseline))
-        (cond (( (aref box-y-size i) -1)
-               (setq height (max height (= (aref box-x-size i) (aref box-x-offset i))))))
-        (cond (( (aref box-y-size i) -1)
-               (setq baseline (max baseline (- (aref box-y-offset i)))))))
-      (do ((i bc (1+ i))
-           (char-width)
-           (raster-height)
-           (raster-width)
-           (char-baseline)
-           (wd)
-           (cd))
-          ((> i ec))
-        (cond (( (aref box-y-size i) -1)
-               (setq char-width (aref xwidths i))
-               (setq raster-width (aref box-x-size i))
-               (setq raster-height (aref box-y-size i))
-               (setq char-y-offset (aref box-y-offset i))
-               (setq cd (fed:make-char-descriptor make-array (nil art-1b (list line-height
-                                                                           raster-width))))
-               (setf (cd-char-width cd) char-width)
-               (and (= ch #\sp) (setf (fed:fd-space-width fd) char-width))
-               (setf (cd-char-left-kern cd) (aref box-x-offset i))
-               (aset cd fd ch)
-               (next-word) (next-word)
-               (dotimes (hpos raster-width)
-                 ;; Read in the next vertical scan line.
-                 (dotimes (vpos raster-height)
-                  ;; If wd is exhausted, get next word into wd
-                  (cond ((zerop (\ vpos 16.))
-                         (setq wd (next-word))))
-                  (setq tem (logand 1 (lsh wd (- (\ hpos 16.)))))
-                  (as-2 tem cd
-                        (+ vpos baseline char-y-offset)
-                        hpos))))))
-      (setf (fed:fd-fill-pointer fd) 200)
-      ;; Set width of blinker and space fields from the space character.
-      (setf (fed:fd-blinker-width fd) (fed:fd-space-width fd))
-      (fed:font-name-set-font-and-descriptor fontname fd)
-      fontname))
-  (close widths-file))))
-);end comment

trunk/lisp/lmio1/serial.lisp

@@ -1 @@
-; -*- Mode:Lisp; Package:System-Internals -*-
-
-; Handler for the serial I/O interface
-
-(declare (special syn1-character syn2-character dle-character ;Can't read these back
-                  uart-registers ;3 bytes, command, mode1, mode2.
-                  serial-unibus-channel serial-unrchf serial-error-mask))
-
-(defun make-serial-stream (&rest keywords
-                           &aux stream (syn1-character 0) (syn2-character 0) (dle-character 0)
-                                (uart-registers 0)
-                                (serial-unibus-channel nil) (serial-unrchf nil)
-                                (serial-error-mask 0)
-                                (request-to-send t) (data-terminal-ready t)
-                                (synchronous-mode nil) (number-of-stop-bits 1)
-                                ;; Default to even parity and 7 data bits,
-                                ;; but don't check received parity.  This causes the
-                                ;; input stream to return 7-bit characters, to avoid
-                                ;; faking out Lisp-machine-oriented programs.
-                                (parity ':even) (number-of-data-bits 7)
-                                (baud 300.))
-  (serial-check-existence)              ;Barf if machine doesn't have a serial I/O port
-  (do l keywords (cddr l) (null l)
-    (selectq (car l)
-      (:check-parity-errors
-        (and (cadr l) (setq serial-error-mask (logior 10 serial-error-mask))))
-      (:check-over-run-errors
-        (and (cadr l) (setq serial-error-mask (logior 20 serial-error-mask))))
-      (:check-framing-errors
-        (and (cadr l) (setq serial-error-mask (logior 40 serial-error-mask))))
-      (:request-to-send (setq request-to-send (cadr l)))
-      (:data-terminal-ready (setq data-terminal-ready (cadr l)))
-      (:synchronous-mode (setq synchronous-mode (cadr l)))
-      (:number-of-stop-bits (setq number-of-stop-bits (cadr l)))
-      (:parity (setq parity (cadr l)))
-      (:number-of-data-bits (setq number-of-data-bits (cadr l)))
-      (:baud (setq baud (cadr l)))
-      (:otherwise (ferror nil "~S unknown keyword" (car l)))))
-  (%unibus-write 764166 20)             ;Reset
-  (%unibus-write 764166 5)              ;Reset command register, rcv & xmt enable
-  (serial-write-mode 60)                ;Reset modes, set to internal clocks
-  (setq uart-registers 30005)           ;60 in mode, 5 in command
-  (setq stream (closure '(syn1-character syn2-character dle-character uart-registers
-                          serial-unibus-channel serial-unrchf serial-error-mask)
-                        'serial-stream))
-  (funcall stream ':put ':synchronous-mode synchronous-mode)
-  (funcall stream ':put ':request-to-send request-to-send)
-  (funcall stream ':put ':data-terminal-ready data-terminal-ready)
-  (funcall stream ':put ':number-of-stop-bits number-of-stop-bits)
-  (funcall stream ':put ':parity parity)
-  (funcall stream ':put ':number-of-data-bits number-of-data-bits)
-  (funcall stream ':put ':baud baud)
-  (funcall stream ':clear-input)        ;Sets up the unibus channel
-  stream)
-
-(defselect (serial-stream serial-stream-default-handler)
-  (:tyo (char)
-    (process-wait "Serial TYO" #'(lambda () (bit-test 1 (%unibus-read 764162))))
-    (%unibus-write 764160 char))
-  (:tyi (&optional ignore &aux ch status)
-    (cond ((null serial-unrchf)
-           (process-wait "Serial TYI" #'unibus-channel-not-empty serial-unibus-channel)
-           (multiple-value (ch status) (read-unibus-channel serial-unibus-channel))
-           (setq ch (logand 377 ch))
-           (cond ((bit-test serial-error-mask status)
-                  ;; Reset the stupid error flags
-                  (%unibus-write 764166 (logior 20 uart-registers))
-                  (%unibus-write 764166 uart-registers)
-                  (cerror t nil nil
-                          "Serial input ~:[framing ~]~:[over-run ~]~:[parity ~]error: ~O"
-                          (zerop (logand 40 status serial-error-mask))
-                          (zerop (logand 20 status serial-error-mask))
-                          (zerop (logand 10 status serial-error-mask))
-                          ch)))
-           ch)
-          (t (prog1 serial-unrchf (setq serial-unrchf nil)))))
-  (:untyi (char)
-    (setq serial-unrchf char))
-  (:listen ()
-           (unibus-channel-not-empty serial-unibus-channel))
-  (:tyi-no-hang ()
-    (and (unibus-channel-not-empty serial-unibus-channel)
-         (serial-stream ':tyi)))
-  (:clear-input ()              ;This fully resets the hardware.
-    (serial-stream ':close)
-    ;; Reset the stupid error flags
-    (%unibus-write 764166 (logior 20 uart-registers))
-    (%unibus-write 764166 uart-registers)
-    (serial-write-mode (%logldb 1020 uart-registers))   ;Restore mode registers
-    (%unibus-read 764160)       ;Flush buffered character if any
-    (setq serial-unibus-channel (get-unibus-channel 264 764162 2 764160 2))
-    (%unibus-write 764112 (dpb 1 0701 (%unibus-read 764112)))) ;Turn on interrupt
-  (:close ()
-    (%unibus-write 764112 (dpb 0 0701 (%unibus-read 764112))) ;Turn off interrupt
-    (return-unibus-channel (prog1 serial-unibus-channel (setq serial-unibus-channel nil))))
-  (:get . serial-get-property)
-  (:put . serial-put-property))
-  
-(defun serial-stream-default-handler (op arg1 &rest rest)
-  (multiple-value-call (stream-default-handler #'serial-stream op arg1 rest)))
-
-;Subroutines for use by the stream
-
-;Read the mode register, MODE1 in high byte
-(defun serial-read-mode ()
-  (%unibus-read 764166)         ;reset MODE1/MODE2 phase
-  (dpb (%unibus-read 764164) 1010 (%unibus-read 764164)))
-
-;Write it
-(defun serial-write-mode (mode)
-  (setq uart-registers (%logdpb mode 1020 uart-registers)) ;remember it
-  (%unibus-read 764166)         ;reset MODE1/MODE2 phase
-  (%unibus-write 764164 (ldb 1010 mode))
-  (%unibus-write 764164 mode))
-
-(defun serial-write-command (cmd)
-  (setq uart-registers (dpb cmd 0010 uart-registers))  ;remember it
-  (%unibus-write 764166 cmd))
-
-(defun serial-write-sync-chars (syn1 syn2 dle)
-  (%unibus-read 764166)         ;reset MODE1/MODE2 phase
-  (%unibus-write 764162 syn1)
-  (%unibus-write 764162 syn2)
-  (%unibus-write 764162 dle))
-
-;Test existence of device.  If IOB not wired for it, will read back
-;all zero.  If PCI not plugged in, will read back all ones.
-(defun serial-check-existence (&aux zeros ones)
-  (%unibus-write 764166 0)
-  (setq zeros (ldb 0010 (%unibus-read 764166)))
-  (%unibus-write 764166 100)
-  (setq ones (ldb 0010 (%unibus-read 764166)))
-  (cond ((zerop ones) (ferror nil "This IOB does not have serial I/O"))
-        ((= zeros 377) (ferror nil "This IOB does not contain a PCI"))))
-
-(defun serial-get-property (ignore prop)        ;:GET operation on the stream
-    (let ((mode (serial-read-mode))
-          (status (%unibus-read 764162))
-          (command (%unibus-read 764166))
-          (synchronous-p nil))
-      (and (zerop (ldb 1002 mode)) (setq synchronous-p t))
-      (selectq prop
-        (:data-set-ready (bit-test 200 status)) ;This might want to be wired to CTS?
-        (:carrier-detect (bit-test 100 status))
-        (:request-to-send (bit-test 40 command))
-        (:data-terminal-ready (bit-test 2 command))
-        (:number-of-stop-bits (if synchronous-p 0
-                                &