Changeset 288


Ignore:
Timestamp:
08/18/11 18:30:58 (3 years ago)
Author:
rjs
Message:

Update from System 78.

Location:
trunk/lisp/lmio1
Files:
7 added
24 deleted
14 edited

Legend:

Unmodified
Added
Removed
  • trunk/lisp/lmio1/cdrive.lisp

    r254 r288  
     1
    12;;-*- MODE: LISP; PACKAGE: USER; -*-
    23
     
    341342    (PROG NIL
    342343          (IF (= (LDB 0003 (%UNIBUS-READ 764102)) 1)    ;Last character new keyboard?
    343             (SELECTQ CH0                        ;Yes, same keys but different glyphs
    344               (#/( (RETURN (* -STEP MULTIPLIER) 0))
    345               (#/[ (RETURN (FIX (* -STEP BIGMULT MULTIPLIER)) 0))
    346               (#/) (RETURN (* STEP MULTIPLIER) 0))
    347               (#/] (RETURN (FIX (* STEP BIGMULT MULTIPLIER)) 0))
    348               (#/` (RETURN 0 (* STEP MULTIPLIER)))
    349               (#/~ (RETURN 0 (FIX (* STEP BIGMULT MULTIPLIER))))
    350               (#/\ (RETURN 0 (* -STEP MULTIPLIER)))
    351               (#/| (RETURN 0 (FIX (* -STEP BIGMULT MULTIPLIER)))))
    352             (SELECTQ CH0
    353               (#/[ (RETURN (* -STEP MULTIPLIER) 0))
    354               (#/{ (RETURN (FIX (* -STEP BIGMULT MULTIPLIER)) 0))
    355               (#/] (RETURN (* STEP MULTIPLIER) 0))
    356               (#/} (RETURN (FIX (* STEP BIGMULT MULTIPLIER)) 0))
    357               (#/\ (RETURN 0 (* STEP MULTIPLIER)))
    358               (#/| (RETURN 0 (FIX (* STEP BIGMULT MULTIPLIER))))
    359               (#// (RETURN 0 (* -STEP MULTIPLIER)))
    360               (#/ (RETURN 0 (FIX (* -STEP BIGMULT MULTIPLIER))))))
     344              (SELECTQ CH0                      ;Yes, same keys but different glyphs
     345                (#/( (RETURN (* -STEP MULTIPLIER) 0))
     346                (#/[ (RETURN (FIX (* -STEP BIGMULT MULTIPLIER)) 0))
     347                (#/) (RETURN (* STEP MULTIPLIER) 0))
     348                (#/] (RETURN (FIX (* STEP BIGMULT MULTIPLIER)) 0))
     349                (#/` (RETURN 0 (* STEP MULTIPLIER)))
     350                (#/~ (RETURN 0 (FIX (* STEP BIGMULT MULTIPLIER))))
     351                (#/\ (RETURN 0 (* -STEP MULTIPLIER)))
     352                (#/| (RETURN 0 (FIX (* -STEP BIGMULT MULTIPLIER)))))
     353              (SELECTQ CH0
     354                (#/[ (RETURN (* -STEP MULTIPLIER) 0))
     355                (#/{ (RETURN (FIX (* -STEP BIGMULT MULTIPLIER)) 0))
     356                (#/] (RETURN (* STEP MULTIPLIER) 0))
     357                (#/} (RETURN (FIX (* STEP BIGMULT MULTIPLIER)) 0))
     358                (#/\ (RETURN 0 (* STEP MULTIPLIER)))
     359                (#/| (RETURN 0 (FIX (* STEP BIGMULT MULTIPLIER))))
     360                (#// (RETURN 0 (* -STEP MULTIPLIER)))
     361                (#/ (RETURN 0 (FIX (* -STEP BIGMULT MULTIPLIER))))))
    361362          (RETURN NIL))))
    362363
     
    624625  (SETQ YPOS-STEPS (+ STEPS YPOS-STEPS)))
    625626
    626 (DEFMETHOD (PROBE-CLASS :CALIBRATE) ()
    627   (PROG (XD YD REDO-CALIB NBOARDS POS)
    628         (FORMAT T "~%REDO CALIBRATOR?")
    629         (COND ((SETQ REDO-CALIB (Y-OR-N-P))
     627(DEFMETHOD (PROBE-CLASS :CALIBRATE) (&OPTIONAL POS NBOARDS NO-ASK)
     628  (PROG (XD YD REDO-CALIB NEXT-POS)
     629        (IF (NULL POS)
     630            (SETQ POS (SELECTQ CTEST-BOARD-TYPE
     631                        (MPG216 "1A01-10")
     632                        (LG684 "A1-10"))))
     633        (COND ((SETQ REDO-CALIB (OR NO-ASK
     634                                    (FQUERY FORMAT:Y-OR-N-P-OPTIONS
     635                                            "~%REDO CALIBRATOR?")))
    630636               (<- CALIBRATOR ':INITIALIZE)))
    631637        (COND ((NULL MILLS-TO-STEPS)
    632638               (SETQ MILLS-TO-STEPS (// 1434. (FLOAT (* 5 MPG216-GXOFST))))))
    633         (FORMAT T (SELECTQ CTEST-BOARD-TYPE
    634                     (MPG216 "~%Position ~S probe over 1A01-10")
    635                     (LG684 "~%Position ~S probe over A1-10"))
    636                     NAME)
    637         (<- SELF ':MANUAL-CONTROL)
    638         (<- SELF ':probe-up)
    639         (COND ((Y-OR-N-P "RECOMPUTE MILLS-TO-STEPS?")
    640                (<- self ':manual-control)
    641                (FORMAT T (SELECTQ CTEST-BOARD-TYPE
    642                            (MPG216 "~%Now position it over 1F01-10")
    643                            (LG684 "~%Now position it over A30-10")))
     639        (FORMAT T "~%Position ~S probe over ~A" NAME POS)
     640        (COND ((NOT NO-ASK)
     641               (<- SELF ':MANUAL-CONTROL)
     642               (<- SELF ':PROBE-UP)
     643               (COND ((Y-OR-N-P "RECOMPUTE MILLS-TO-STEPS?")
     644                      (<- SELF ':MANUAL-CONTROL)
     645                      (SETQ NEXT-POS (SELECTQ CTEST-BOARD-TYPE
     646                                       (MPG216 "1F01-10")
     647                                       (LG684 "A30-10")))
     648                      (FORMAT T "~%Now position it over ~A" NEXT-POS)
    644649               (<- SELF ':probe-up)
    645650               (MULTIPLE-VALUE (XD YD) (<- self ':manual-control ctest-slow-speed))
     
    649654                                               (MPG216 (* 5 MPG216-GXOFST))
    650655                                               (LG684 (* 30. LG684-XDIPSP))))))
    651                (SETQ POS (SELECTQ CTEST-BOARD-TYPE
    652                            (MPG216 "1F01-10")
    653                            (LG684 "A30-10")))
    654                (<- SELF ':DEFINE-POSITION-STRING-LOC POS))
    655               (T (SETQ POS (SELECTQ CTEST-BOARD-TYPE
    656                              (MPG216 "1A01-10")
    657                              (LG684 "A1-10")))
    658                  (<- SELF ':DEFINE-POSITION-STRING-LOC POS)))
     656               (SETQ POS NEXT-POS)))))
     657        (<- SELF ':DEFINE-POSITION-STRING-LOC POS)
    659658        (COND (REDO-CALIB
    660659               (SELECTQ CTEST-BOARD-TYPE
    661660                 (MPG216
    662                   (FORMAT T "~%HOW MANY BOARDS?")
    663                   (SETQ NBOARDS (READ))
     661                  (IF (NULL NBOARDS)
     662                      (PROGN (FORMAT T "~%HOW MANY BOARDS?")
     663                             (SETQ NBOARDS (READ))))
    664664                  (DOTIMES (C NBOARDS)
    665665                    (CALIBRATE-AT-LOC (1+ C) (FORMAT NIL "~DA1-10" (1+ C)) CALIBRATOR)
     
    724724          NAME (<- CALIBRATOR ':CALIBRATION-POINTS)))
    725725 
     726
    726727(DEFUN CTEST-CALIBRATE NIL
    727   (<- LEFT-PROBE ':CALIBRATE)
    728   (<- RIGHT-PROBE ':CALIBRATE))
     728  (<- RIGHT-PROBE ':CALIBRATE)
     729  (<- RIGHT-PROBE ':STEP-X -400)                ;clear field
     730  (<- LEFT-PROBE ':CALIBRATE))
     731
     732(DEFUN TEST-ICMEM (&OPTIONAL NO-CAL)
     733  (IF (NULL NO-CAL) (SETUP 2))
     734  (SETQ CTEST-BAD-RUNS NIL)
     735  (CTEST-PROCESS-WLR "CADRWD;ICMEM3 WLR"))
     736
     737(DEFUN TEST-CADR (&OPTIONAL NO-CAL)
     738  (IF (NULL NO-CAL) (SETUP 4))
     739  (SETQ CTEST-BAD-RUNS NIL)
     740  (CTEST-PROCESS-WLR "CADRWD;CADR4 WLR"))
     741
     742(DEFUN SETUP (NBOARDS)
     743  (FQUERY FORMAT:Y-OR-N-P-OPTIONS
     744          "~% Is the right probe over 1A01-10 and the left probe over 1AJ1-1?")
     745  (SETUP-RIGHT NBOARDS "1A01-10")
     746  (SETUP-LEFT NBOARDS  "1AJ1-1"))
     747
     748(DEFUN SETUP-RIGHT (NBOARDS &OPTIONAL (POS "1A01-10"))
     749  (<- RIGHT-PROBE ':CALIBRATE POS NBOARDS T)
     750  (<- RIGHT-PROBE ':STEP-X -400))               ;clear field
     751
     752(DEFUN SETUP-LEFT (NBOARDS &OPTIONAL (POS "1A01-10"))
     753  (<- LEFT-PROBE ':CALIBRATE POS NBOARDS T))
    729754
    730755(DEFUN PRINT-CALIBRATION NIL
  • trunk/lisp/lmio1/chatst.lisp

    r254 r288  
    2020;;;                          debugging in order for interrupts to work!
    2121
     22(DEFVAR CHATST-USE-DEBUG NIL)   ;if T, everything refers to machine on debug interface
     23(DEFVAR CHATST-PACKET-LENGTH 20)        ;Packet length chatst sends
     24
    2225;;;  **** NOTE *****
    2326;;;  Here are some typical screws encountered in testing chaos boards:
     
    5861
    5962
     63(DEFMACRO INITIATE-PACKET-TRANSMISSION ()
     64  '(%U-READ INITIATE-TRANSFER-REGISTER-TEST))
     65
    6066(DEFUN SET-BASE-ADDRESS (&OPTIONAL (BASE-ADDRESS 764140))
    6167    "Set the base UNIBUS address for the Chaos net device.
     
    7379          INTERVAL-TIMER-REGISTER-TEST
    7480          (+ BASE-ADDRESS 20))
    75     (FORMAT T "~%My number: ~O" (setq chatst-address (%unibus-read MY-NUMBER-REGISTER-TEST))))
    76 
    77 (SET-BASE-ADDRESS)
     81    (FORMAT T "~%My number: ~O" (setq chatst-address (%u-read MY-NUMBER-REGISTER-TEST))))
    7882
    7983(DEFVAR CHATST-PATTERN (MAKE-ARRAY NIL 'ART-16B 256.))
     
    8387(DEFUN SET-PATTERN (PAT)
    8488  (SETQ CHATST-PATTERN-TYPE PAT)
    85   (DO I 0 (1+ I) (= I 20)
     89  (DO I 0 (1+ I) (= I CHATST-PACKET-LENGTH)
    8690    (AS-1 (COND ((EQ PAT 'FLOATING-ONE) (LSH 1 I))
    8791                ((EQ PAT 'FLOATING-ZERO) (LOGXOR (LSH 1 I) -1))
     
    96100(DEFVAR CHATST-USE-RECEIVE-ALL T)               ;reasonable???
    97101
    98 (DEFUN CHATST ()
     102(DEFUN CHATST (&OPTIONAL (LOOPBACK-COUNT 4) (CABLE-COUNT 4))
    99103    "Standard test function for the chaos network interface.
    100104If it passes this test, sending and receiving packets from the network
     
    105109It does not send a properly formated packet with a header, but just
    106110a packet of raw bits."
     111    (IF CHATST-USE-DEBUG (FORMAT T "~%Using debug interface"))
    107112    (CHATST-RESET)
    108113    (DOLIST (PAT '(FLOATING-ONE FLOATING-ZERO ADDRESS 52525 0 177777))
     
    110115      (SET-PATTERN PAT)
    111116      (LET ((CHATST-USE-RECEIVE-ALL T))
    112         (DO I 0 (1+ I) (= I 4) (CHATST-PREP T) (CHATST-XMT) (CHATST-RCV)))
     117        (DOTIMES (I LOOPBACK-COUNT)
     118          (CHATST-PREP T) (CHATST-XMT) (CHATST-RCV)))
    113119      (FORMAT T "~%Using the cable ~%")
    114120      (LET ((CHATST-USE-RECEIVE-ALL NIL))
    115         (DO I 0 (1+ I) (= I 4) (CHATST-PREP NIL) (CHATST-XMT) (CHATST-RCV T)))))
     121        (DOTIMES (I CABLE-COUNT)
     122          (CHATST-PREP NIL) (CHATST-XMT) (CHATST-RCV T)))))
    116123
    117124(DEFUN CHATST-ONCE (&OPTIONAL (LOOPBACK NIL) (CHATST-USE-RECEIVE-ALL LOOPBACK))
     
    124131(DEFUN CHATST-TR-LOOP (&OPTIONAL LOOPBACK &AUX (CHATST-USE-RECEIVE-ALL LOOPBACK))
    125132  (CHATST-RESET)
    126   (DO () ((KBD-TYI-NO-HANG)) (CHATST-PREP LOOPBACK) (CHATST-XMT) (CHATST-RCV T)))
     133  (DO () ((FUNCALL TERMINAL-IO ':TYI-NO-HANG)) (CHATST-PREP LOOPBACK)
     134      (CHATST-XMT) (CHATST-RCV T)))
    127135
    128136(DEFUN CHATST-XMT ()
    129     "Send a packet consisting of 16 rotating 1's and my address."
    130     (DO I 0 (1+ I) (= I 20)
    131         (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
    132     (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST (%UNIBUS-READ MY-NUMBER-REGISTER-TEST))
    133     (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST ;improve chances of avoiding an abort
    134                    (LOGIOR 10 (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST)))
    135     (%UNIBUS-READ INITIATE-TRANSFER-REGISTER-TEST))
    136 
    137 (DEFUN CHATST-PACKET (&OPTIONAL (CABLE-DEST 440))       ;MC-11
     137    "Send a packet consisting of 16 words of selected pattern and my address."
     138    (DO I 0 (1+ I) (= I CHATST-PACKET-LENGTH)
     139        (%u-write WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
     140    (%u-write WRITE-BUFFER-REGISTER-TEST (%U-READ MY-NUMBER-REGISTER-TEST))
     141    (%u-write CONTROL-STATUS-REGISTER-TEST      ;improve chances of avoiding an abort
     142                   (LOGIOR 10 (%U-READ CONTROL-STATUS-REGISTER-TEST)))
     143    (INITIATE-PACKET-TRANSMISSION))
     144
     145(DEFUN CHATST-PACKET (&OPTIONAL (CABLE-DEST 3040))      ;MC-11
    138146    "Send a packet to some host (defaults to MC) which it will echo back."
    139   (DO () ((bit-test 200 (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST)))) ;AWAIT TDONE
    140   (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST 100000)  ;DATA
    141   (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST 40) ;NBYTES
    142   (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST 1440)       ;MC
    143   (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST 0)
    144   (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST chatst-address)     ;LISPM
     147  (DO () ((bit-test 200 (%U-READ CONTROL-STATUS-REGISTER-TEST)))) ;AWAIT TDONE
     148  (%u-write WRITE-BUFFER-REGISTER-TEST 100000)  ;DATA
     149  (%u-write WRITE-BUFFER-REGISTER-TEST 40)      ;NBYTES
     150  (%u-write WRITE-BUFFER-REGISTER-TEST 1440)    ;MC
     151  (%u-write WRITE-BUFFER-REGISTER-TEST 0)
     152  (%u-write WRITE-BUFFER-REGISTER-TEST chatst-address)  ;LISPM
    145153  (DO I 0 (1+ I) (= I 3)                        ;SEND THE PATTERN AS IDX, PKT, ACK
    146     (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
    147   (DO I 0 (1+ I) (= I 20)                       ;SEND THE PATTERN AS 40 BYTES OF DATA
    148     (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
    149   (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST CABLE-DEST)
    150   (%UNIBUS-READ INITIATE-TRANSFER-REGISTER-TEST))
    151 
    152 
    153 (DEFUN CHATST-LOOP (&OPTIONAL (CABLE-DEST 440) (LOOP-BACK-P NIL))       ;MC-11, NO LOOPBACK
     154    (%u-write WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
     155  (DO I 0 (1+ I) (= I CHATST-PACKET-LENGTH)     ;SEND THE PATTERN AS 40 BYTES OF DATA
     156    (%u-write WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
     157  (%u-write WRITE-BUFFER-REGISTER-TEST CABLE-DEST)
     158  (INITIATE-PACKET-TRANSMISSION))
     159
     160
     161(DEFUN CHATST-LOOP (&OPTIONAL (CABLE-DEST 3040) (LOOP-BACK-P NIL))      ;MC-11, NO LOOPBACK
    154162    "Scope loop, ignore what is received (defaults to mc)"
    155     (DO () ((KBD-TYI-NO-HANG))
     163    (DO () ((FUNCALL TERMINAL-IO ':TYI-NO-HANG))
    156164      (CHATST-PREP LOOP-BACK-P)
    157165      (CHATST-PACKET CABLE-DEST)))
     
    159167;;; Prepare the interface to receive.
    160168(DEFUN CHATST-PREP (LOOPBACK-P)
    161   (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST
     169  (%u-write CONTROL-STATUS-REGISTER-TEST
    162170                 (+ (COND ((NOT LOOPBACK-P) 10) (T 12))
    163171                    (COND ((NOT CHATST-USE-RECEIVE-ALL) 0) (T 4)))))
    164172
    165173(DEFUN CHATST-RESET ()
    166     (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST 20000))
     174    (%u-write CONTROL-STATUS-REGISTER-TEST 20000))
    167175
    168176(SETQ INBUF (MAKE-ARRAY NIL 'ART-16B 256.))
     
    170178
    171179;;; Look for a received packet, and complain in various ways.
    172 (DEFUN CHATST-RCV ( &OPTIONAL BUSY-WAIT (CNT 16.) &AUX CSR TEM ME LOSE)
     180(DEFUN CHATST-RCV ( &OPTIONAL BUSY-WAIT (CNT CHATST-PACKET-LENGTH) &AUX CSR TEM ME LOSE)
    173181  (IF BUSY-WAIT
    174182      (DO () ((LDB-TEST %%CHAOS-CSR-RECEIVE-DONE
    175                         (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))))
     183                        (%U-READ CONTROL-STATUS-REGISTER-TEST))))
    176184      (PROCESS-SLEEP 10.))  ;Give it time to arrive
    177   (SETQ CSR (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))
    178   (SETQ ME (%UNIBUS-READ MY-NUMBER-REGISTER-TEST))
     185  (SETQ CSR (%U-READ CONTROL-STATUS-REGISTER-TEST))
     186  (SETQ ME (%U-READ MY-NUMBER-REGISTER-TEST))
    179187  (IF (LDB-TEST %%CHAOS-CSR-TRANSMIT-ABORT CSR)
    180188      (FORMAT t "~%Transmit aborted, then~%"))
     
    182190         (SETQ LOSE T) (PRINT 'NO-RECEIVE))
    183191        (T (AND (LDB-TEST %%CHAOS-CSR-CRC-ERROR CSR)
    184                 (PROGN (SETQ LOSE T)
     192                (PROGN (SETQ LOSE 'CRC)
    185193                       (PRINT '"CRC Error indicated (check the data)")))
    186            (OR (= (%UNIBUS-READ BIT-COUNT-REGISTER-TEST) (1- (* 16. (+ 3 CNT))))
     194           (OR (= (%U-READ BIT-COUNT-REGISTER-TEST) (1- (* 16. (+ 3 CNT))))
    187195               (PROGN (SETQ LOSE T)
    188                       (PRINT (LIST (%UNIBUS-READ BIT-COUNT-REGISTER-TEST) 'BAD-BIT-COUNT))))
     196                      (PRINT (LIST (%U-READ BIT-COUNT-REGISTER-TEST) 'BAD-BIT-COUNT))))
    189197           (DO I 0 (1+ I) (= I CNT)
    190              (AS-1 (%UNIBUS-READ READ-BUFFER-REGISTER-TEST) INBUF I))
    191            (OR (= (SETQ TEM (%UNIBUS-READ READ-BUFFER-REGISTER-TEST)) ME)
     198             (AS-1 (%U-READ READ-BUFFER-REGISTER-TEST) INBUF I))
     199           (IF ( (SETQ TEM (%U-READ READ-BUFFER-REGISTER-TEST)) ME)
    192200               (PROGN (SETQ LOSE T)
    193201                      (FORMAT T "~% DEST=~O SHOULD=~O" TEM ME)))
    194            (OR (= (SETQ TEM (%UNIBUS-READ READ-BUFFER-REGISTER-TEST)) ME)
     202           (IF ( (SETQ TEM (%U-READ READ-BUFFER-REGISTER-TEST)) ME)
    195203               (PROGN (SETQ LOSE T)
    196204                      (FORMAT T "~% SOURCE=~O SHOULD=~O" TEM ME)))
     
    204212                    (DO I 0 (1+ I) (= I CNT)
    205213                      (FORMAT T "~%~2O  ~6O ~6O" I (AR-1 CHATST-PATTERN I) (AR-1 INBUF I)))
    206                     (RETURN NIL))))))
     214                    (RETURN NIL))))
     215           (%U-READ READ-BUFFER-REGISTER-TEST)  ;gobble the CRC word
     216           (IF (AND (NOT (EQ LOSE 'CRC))        ;don't bother pointing this out, if already
     217                    (LDB-TEST %%CHAOS-CSR-CRC-ERROR (%U-READ CONTROL-STATUS-REGISTER-TEST)))
     218               (PROGN (FORMAT T "~%CRC error indicated after data readout~:[ even though data is correct~]."
     219                              LOSE)
     220                      (SETQ LOSE T)))
     221           ))
    207222  (OR LOSE (FORMAT T "~&WIN")))
    208223
     
    215230  a random host sending garbage packets, etc."
    216231  (CHATST-RESET)
    217       (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST 14)        ;reset rcvr, RCV ALL
    218   (DO () ((KBD-CHAR-AVAILABLE) (KBD-TYI-NO-HANG))
     232  (%u-write CONTROL-STATUS-REGISTER-TEST 14)        ;reset rcvr, RCV ALL
     233  (DO () ((FUNCALL TERMINAL-IO ':LISTEN) (FUNCALL TERMINAL-IO ':TYI-NO-HANG))
    219234    (DO ((i 0 (1+ i)))
    220235        ((> I 50.) (FORMAT T "."))
    221       (COND ((bit-test 100000 (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))
     236      (COND ((bit-test 100000 (%U-READ CONTROL-STATUS-REGISTER-TEST))
    222237             (FORMAT T "~%---------------------~%")
    223              (AND (LDB-TEST %%CHAOS-CSR-CRC-ERROR (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))
     238             (AND (LDB-TEST %%CHAOS-CSR-CRC-ERROR (%U-READ CONTROL-STATUS-REGISTER-TEST))
    224239                  (FORMAT T "CRC-Error "))
    225              (SETQ BITS (1+ (%UNIBUS-READ BIT-COUNT-REGISTER-TEST))
     240             (SETQ BITS (1+ (%U-READ BIT-COUNT-REGISTER-TEST))
    226241                   CNT (// BITS 16.))
    227242             (OR (ZEROP (\  BITS 16.))
     
    229244             (COND ((AND SHORT-P (> CNT 8))
    230245                    (DO I 0 (1+ I) (= I 5)
    231                         (FORMAT T "~&~O   ~O" I (%UNIBUS-READ READ-BUFFER-REGISTER-TEST)))
     246                        (FORMAT T "~&~O   ~O" I (%U-READ READ-BUFFER-REGISTER-TEST)))
    232247                    (FORMAT T "~%     ...")
    233248                    (DO I 0 (1+ I) (
    234  I (- CNT 8))(%UNIBUS-READ READ-BUFFER-REGISTER-TEST))
    235                     (DO I (- CNT 3) (1+ I) (= I CNT)
    236                         (FORMAT T "~%~O   ~O" I (%UNIBUS-READ READ-BUFFER-REGISTER-TEST))))
     249 I (- CNT 8))(%U-READ READ-BUFFER-REGISTER-TEST))
     250                    (LET ((D (%U-READ READ-BUFFER-REGISTER-TEST))
     251                          (S (%U-READ READ-BUFFER-REGISTER-TEST))
     252                          (CRC  (%U-READ READ-BUFFER-REGISTER-TEST)))
     253                      (FORMAT T "~% dest ~O  ~A" D (SI:GET-HOST-FROM-ADDRESS D ':CHAOS))
     254                      (FORMAT T "~% src  ~O  ~A" S (SI:GET-HOST-FROM-ADDRESS S ':CHAOS))
     255                      (FORMAT T "~% CRC ~O" CRC)))
    237256                   (T (DO I 0 (1+ I) (= I CNT)
    238                           (FORMAT T "~&~O   ~O" I (%UNIBUS-READ READ-BUFFER-REGISTER-TEST)))))
    239              (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST 14)        ;reset rcvr, RCV ALL
     257                          (FORMAT T "~&~O   ~O" I (%U-READ READ-BUFFER-REGISTER-TEST)))))
     258             (%u-write CONTROL-STATUS-REGISTER-TEST 14)        ;reset rcvr, RCV ALL
    240259             (RETURN NIL)))))
    241260  (CHATST-RESET))
     
    248267   (AS-1 100000 CHATST-HEADER 0)                   ;OPCODE (DATA)
    249268   (AS-1 0 CHATST-HEADER 1)                        ;LENGTH IN BYTES
    250    (AS-1 chatst-address CHATST-HEADER 2)               ;DESTINATION (CAUSE FORWARDING)
     269   (AS-1 chatst-address CHATST-HEADER 2)           ;DESTINATION (CAUSE FORWARDING)
    251270   (AS-1 0 CHATST-HEADER 3)
    252    (AS-1 chatst-address CHATST-HEADER 4)               ;SOURCE
     271   (AS-1 chatst-address CHATST-HEADER 4)           ;SOURCE
    253272   (DO I 0 (1+ I) (= I 3)                          ;SRC-IDX, PK#, ACK#
    254273       (AS-1 (AR-1 CHATST-PATTERN I) CHATST-HEADER (+ I 5))))
    255274
    256 (CHATST-SET-HEADER)                                ;Setup an echo header
    257 
    258 (DEFUN CHATST-ECHO (&OPTIONAL (DEST 440)  (LEN 20))
     275(DEFUN CHATST-ECHO (&OPTIONAL (DEST 3040)  (LEN CHATST-PACKET-LENGTH))
    259276  (CHATST-RESET)
    260   (SETQ LEN (MIN LEN 248.))         ;4096.-header
     277  (CHATST-SET-HEADER)                           ;Setup an echo header
     278  (SETQ LEN (MIN LEN 248.))                     ;4096.-header
    261279  (AS-1 (* LEN 2) CHATST-HEADER 1)
    262280  (DO ((pat1 0 (1+ pat1))
    263281       (pat2 (random) (random)))
    264       ((KBD-TYI-NO-HANG))
    265     (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST 10)        ;reset rcvr
    266       (do i 0 (+ i 2) (
     282      ((FUNCALL TERMINAL-IO ':TYI-NO-HANG))
     283    (%u-write CONTROL-STATUS-REGISTER-TEST 10)  ;reset rcvr
     284    (do i 0 (+ i 2) (
    267285 i len)
    268           (as-1 pat1 chatst-pattern i)
    269           (as-1 pat2 chatst-pattern (1+ i)))
    270       (format t "~%Patterns ~O, ~O" pat1 pat2)
    271       ;;Try this pattern 10. times
    272       (do ((j 0 (1+ j))) ((= j 10.))
    273           (DO ((i 0 (1+ i)))
    274               ((bit-test 200 (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))) ;AWAIT TDONE
    275               (COND ((> i 50.)
    276                      (FORMAT T "~% TDONE timeout")
    277                      (RETURN NIL))))
    278           (DO I 0 (1+ I) (= I 8)    ;Fill in IDX, PKT, ACK with pattern
    279               (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-HEADER I)))
    280           (DO I 0 (1+ I) (= I LEN)
    281               (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
    282           (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST 10)    ;reset rcvr
    283           (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST DEST)
    284           (%UNIBUS-READ INITIATE-TRANSFER-REGISTER-TEST)     ;start xmission
    285           (DO ((i 0 (1+ i)))
    286               ((> I 1000.) (FORMAT T "~% Rcv-done timeout"))
    287               (COND ((BIT-TEST 100000 (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))
    288                      (CHATST-CHECK-PK DEST LEN)
    289                      (RETURN NIL)))) )))
     286        (as-1 pat1 chatst-pattern i)
     287        (as-1 pat2 chatst-pattern (1+ i)))
     288    (format t "~%Patterns ~O, ~O" pat1 pat2)
     289    ;;Try this pattern 10. times
     290    (do ((j 0 (1+ j))) ((= j 10.))
     291      (DO ((i 0 (1+ i)))
     292          ((bit-test 200 (%U-READ CONTROL-STATUS-REGISTER-TEST)))       ;AWAIT TDONE
     293        (COND ((> i 50.)
     294               (FORMAT T "~% TDONE timeout")
     295               (RETURN NIL))))
     296      (DO I 0 (1+ I) (= I 8)                    ;Fill in IDX, PKT, ACK with pattern
     297          (%u-write WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-HEADER I)))
     298      (DO I 0 (1+ I) (= I LEN)
     299          (%u-write WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
     300      (%u-write CONTROL-STATUS-REGISTER-TEST 10)        ;reset rcvr
     301      (%u-write WRITE-BUFFER-REGISTER-TEST DEST)
     302      (INITIATE-PACKET-TRANSMISSION)
     303      (DO ((i 0 (1+ i)))
     304          ((OR (bit-test 100 (%U-READ CONTROL-STATUS-REGISTER-TEST))
     305               (> I 1000.))
     306           (IF (bit-test 100 (%U-READ CONTROL-STATUS-REGISTER-TEST))
     307               (FORMAT T "~%Transmit aborted.")
     308               (FORMAT T "~% Rcv-done timeout")))
     309        (COND ((BIT-TEST 100000 (%U-READ CONTROL-STATUS-REGISTER-TEST))
     310               (CHATST-CHECK-PK DEST LEN T)
     311               (RETURN NIL)))) )))
    290312
    291313;;Scope trace - echo from some host
    292314
    293 (DEFUN CHATST-BUZZ (&OPTIONAL (DEST 440) (LEN 20))
     315(DEFUN CHATST-BUZZ (&OPTIONAL (DEST 3040) (LEN CHATST-PACKET-LENGTH))
    294316  (CHATST-RESET)
    295   (SETQ LEN (MIN LEN 248.))         ;4096.-header
     317  (SETQ LEN (MIN LEN 248.))                     ;4096.-header
    296318  (AS-1 (* LEN 2) CHATST-HEADER 1)
    297   (DO () ((KBD-TYI-NO-HANG)(CHATST-PRINT-STATUS DEST LEN))
    298       (as-1 (1+ (ar-1 chatst-pattern 0)) chatst-pattern 0)
    299       ;;Try this pattern 10. times
    300       (do ((j 0 (1+ j))) ((= j 10.))
    301           ;;Wait for Transmit side idle
    302           (DO ((i 0 (1+ i)))
    303               ((bit-test 200 (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST)))
    304               (COND ((> i 50.)
    305                      (FORMAT T "~% TDONE timeout")
    306                      (RETURN NIL))))
    307           ;;Fill in header, data with pattern
    308           (DO I 0 (1+ I) (= I 8)
    309               (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-HEADER I)))
    310           (DO I 0 (1+ I) (= I LEN)
    311               (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
    312           (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST DEST)
    313           ;;Now wait for echoed packet
    314           (DO ((i 0 (1+ i)))
    315               ((> I 50.))
    316               (COND ((bit-test 100000 (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))
    317                      (RETURN NIL))))
    318           (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST (IF (= DEST 0) 12 10))
    319           (%UNIBUS-READ INITIATE-TRANSFER-REGISTER-TEST))))
    320 
    321 (DEFUN CHATST-PRINT-STATUS ( &OPTIONAL (DEST 100) (LEN 16.))
     319  (DO ()
     320      ((FUNCALL TERMINAL-IO ':TYI-NO-HANG)
     321       (CHATST-PRINT-STATUS DEST LEN))
     322    (as-1 (1+ (ar-1 chatst-pattern 0)) chatst-pattern 0)
     323    ;;Try this pattern 10. times
     324    (do ((j 0 (1+ j))) ((= j 10.))
     325      ;;Wait for Transmit side idle
     326      (DO ((i 0 (1+ i)))
     327          ((bit-test 200 (%U-READ CONTROL-STATUS-REGISTER-TEST)))
     328        (COND ((> i 50.)
     329               (FORMAT T "~% TDONE timeout")
     330               (RETURN NIL))))
     331      ;;Fill in header, data with pattern
     332      (DO I 0 (1+ I) (= I 8)
     333          (%u-write WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-HEADER I)))
     334      (DO I 0 (1+ I) (= I LEN)
     335          (%u-write WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
     336      (%u-write WRITE-BUFFER-REGISTER-TEST DEST)
     337      ;;Now wait for echoed packet
     338      (DO ((i 0 (1+ i)))
     339          ((> I 50.))
     340        (COND ((bit-test 100000 (%U-READ CONTROL-STATUS-REGISTER-TEST))
     341               (RETURN NIL))))
     342      (%u-write CONTROL-STATUS-REGISTER-TEST (IF (= DEST 0) 12 10))
     343      (INITIATE-PACKET-TRANSMISSION))))
     344
     345(DEFUN CHATST-PRINT-STATUS ( &OPTIONAL (DEST 100) (LEN CHATST-PACKET-LENGTH))
    322346  (TERPRI)
    323347  (PROCESS-SLEEP 30.)  ;Give it time to arrive
     
    327351
    328352
    329 (DEFUN CHATST-CHECK-PK (&OPTIONAL (DEST-HOST 100) (CNT 16.) &AUX DEST CSR TEM ME BITS)
    330   (SETQ CSR (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST)
    331         ME (%UNIBUS-READ MY-NUMBER-REGISTER-TEST)
    332         BITS (1- (* 16. (+ 11. CNT)))
    333         DEST DEST-HOST)
     353(DEFUN CHATST-CHECK-PK (&OPTIONAL (DEST-HOST 100) (CNT CHATST-PACKET-LENGTH) IGNORE-DEST-0
     354                        &AUX (CSR (%U-READ CONTROL-STATUS-REGISTER-TEST))
     355                             ME BITS BITS1 DEST SRC1 DEST1)
     356  (SETQ ME (%U-READ MY-NUMBER-REGISTER-TEST)
     357        BITS (1- (* 16. (+ 11. CNT)))
     358        BITS1 (%U-READ BIT-COUNT-REGISTER-TEST)
     359        DEST DEST-HOST
     360        SRC1 (%U-READ READ-BUFFER-REGISTER-TEST)
     361        DEST1 (%U-READ READ-BUFFER-REGISTER-TEST))
    334362  (AND (LDB-TEST %%CHAOS-CSR-CRC-ERROR CSR)
    335363       (PRINT 'CRC-ERROR))
    336   (OR (= (SETQ TEM (%UNIBUS-READ BIT-COUNT-REGISTER-TEST)) BITS)
    337       (FORMAT T "~%Bad bit count, is ~O, should be ~O" TEM BITS))
    338   (DO I 0 (1+ I) (= I (+ 8 CNT))
    339       (AS-1 (%UNIBUS-READ READ-BUFFER-REGISTER-TEST) INBUF I))
    340   (OR (= (SETQ TEM (%UNIBUS-READ READ-BUFFER-REGISTER-TEST)) ME)
    341          (FORMAT T "~% DEST=~O, should be ~O"  TEM ME))
    342   (OR (= (SETQ TEM (%UNIBUS-READ READ-BUFFER-REGISTER-TEST)) DEST)
    343          (FORMAT T "~% SOURCE=~O, should be ~O"  TEM DEST))
    344   (AS-1 (LOGAND (AR-1 INBUF 1) 7777) INBUF 1)           ;FLUSH FORWARDING COUNT
    345   (DO I 0 (1+ I) (= I 8)
    346       (COND (( (AR-1 CHATST-HEADER I) (AR-1 INBUF I))
    347              (TERPRI) (PRINC "HEADER  SENT    RCVD")
    348              (DO I 0 (1+ I) (= I 8)
    349                  (FORMAT T "~%~2O  ~6O ~6O" I (AR-1 CHATST-HEADER I) (AR-1 INBUF I)))
    350              (RETURN NIL))))
    351   (DO ((I 0 (1+ I)) (J 8 (1+ J))) ((= I CNT))
    352       (COND (( (AR-1 CHATST-PATTERN I) (AR-1 INBUF J))
    353              (TERPRI) (PRINC "LOC    SENT    RCVD")
    354              (DO ((I 0 (1+ I))(J 8 (1+ J))) ((= I CNT))
    355                  (FORMAT T "~%~2O  ~6O ~6O" I (AR-1 CHATST-PATTERN I) (AR-1 INBUF J)))
    356              (RETURN NIL))))
    357   (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST 10)    ;reset rcvr
    358 )
    359 
    360 (DEFUN CHATST-ECHO-ONCE (&OPTIONAL (DEST 500) (LEN 20))
    361        (DO ()((bit-test 200 (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))))
     364  (DO I 0 (1+ I) (= I (+ 8 CNT))                ;skip first words of header
     365      (AS-1 (%U-READ READ-BUFFER-REGISTER-TEST) INBUF I))
     366  (COND ((AND IGNORE-DEST-0 (= DEST1 0)))
     367        (T (OR (= BITS1 BITS)
     368               (FORMAT T "~%Bad bit count, is ~O, should be ~O" BITS1 BITS))
     369           (OR (= DEST1 ME) (FORMAT T "~% DEST=~O, should be ~O"  DEST1 ME))
     370           (OR (= SRC1 DEST) (FORMAT T "~% SOURCE=~O, should be ~O"  SRC1 DEST))
     371           (AS-1 (LOGAND (AR-1 INBUF 1) 7777) INBUF 1)  ;FLUSH FORWARDING COUNT
     372           (DO I 0 (1+ I) (= I 8)
     373               (COND (( (AR-1 CHATST-HEADER I) (AR-1 INBUF I))
     374                      (TERPRI) (PRINC "HEADER  SENT    RCVD")
     375                      (DO I 0 (1+ I) (= I 8)
     376                          (FORMAT T "~%~2O  ~6O ~6O" I (AR-1 CHATST-HEADER I) (AR-1 INBUF I)))
     377                      (RETURN NIL))))
     378           (DO ((I 0 (1+ I)) (J 8 (1+ J))) ((= I CNT))
     379             (COND (( (AR-1 CHATST-PATTERN I) (AR-1 INBUF J))
     380                    (TERPRI) (PRINC "LOC    SENT    RCVD")
     381                    (DO ((I 0 (1+ I))(J 8 (1+ J))) ((= I CNT))
     382                      (FORMAT T "~%~2O  ~6O ~6O" I (AR-1 CHATST-PATTERN I) (AR-1 INBUF J)))
     383                    (RETURN NIL))))))
     384  (%u-write CONTROL-STATUS-REGISTER-TEST 10)    ;reset rcvr
     385           )
     386
     387(DEFUN CHATST-ECHO-ONCE (&OPTIONAL (DEST 500) (LEN CHATST-PACKET-LENGTH))
     388       (DO ()((bit-test 200 (%U-READ CONTROL-STATUS-REGISTER-TEST))))
    362389       (DO I 0 (1+ I) (= I LEN)                 ;SEND THE PATTERN AS 40 BYTES OF DATA
    363            (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
    364       (%UNIBUS-WRITE WRITE-BUFFER-REGISTER-TEST DEST)
    365       (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST 10)    ;reset rcvr
    366       (%UNIBUS-READ INITIATE-TRANSFER-REGISTER-TEST)
     390           (%u-write WRITE-BUFFER-REGISTER-TEST (AR-1 CHATST-PATTERN I)))
     391      (%u-write WRITE-BUFFER-REGISTER-TEST DEST)
     392      (%u-write CONTROL-STATUS-REGISTER-TEST 10)    ;reset rcvr
     393      (INITIATE-PACKET-TRANSMISSION)
    367394      (DO ((i 0 (1+ i)))
    368           ((or (bit-test 200 (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))
     395          ((or (bit-test 200 (%U-READ CONTROL-STATUS-REGISTER-TEST))
    369396               (> i 50.)))) ;AWAIT TDONE
    370       (%UNIBUS-WRITE CONTROL-STATUS-REGISTER-TEST 14)        ;RCV ALL
     397      (%u-write CONTROL-STATUS-REGISTER-TEST 14)        ;RCV ALL
    371398      (CHATST-PRINT-STATUS DEST LEN))
    372399
     
    374401    "Describes the bits currently on in the control status register for the
    375402board being tested."
    376     (SETQ CSR (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))
     403    (SETQ CSR (%U-READ CONTROL-STATUS-REGISTER-TEST))
    377404    (FORMAT T "~2%CSR = ~O~%" CSR)
    378405    (AND (LDB-TEST %%CHAOS-CSR-TIMER-INTERRUPT-ENABLE CSR)
     
    400427    (AND (LDB-TEST %%CHAOS-CSR-RECEIVE-DONE CSR)
    401428         (FORMAT T "Receive done.~%"))
    402     (FORMAT T "Bit count: ~O~%" (%UNIBUS-READ BIT-COUNT-REGISTER-TEST))
     429    (FORMAT T "Bit count: ~O~%" (%U-READ BIT-COUNT-REGISTER-TEST))
    403430    NIL)
    404431
    405432(DEFUN CHATST-SOAK (&AUX (M-ONES 0) (OTHERS 0))
    406   (%unibus-write control-status-register-test 14)
    407   (DO () ((KBD-TYI-NO-HANG) (FORMAT T "~%-1 length packets ~O, others ~O" m-ones others))
    408     (COND ((bit-test 100000 (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))
     433  (%u-write control-status-register-test 14)
     434  (DO () ((FUNCALL TERMINAL-IO ':TYI-NO-HANG) (FORMAT T "~%-1 length packets ~O, others ~O" m-ones others))
     435    (COND ((bit-test 100000 (%U-READ CONTROL-STATUS-REGISTER-TEST))
    409436;          (DO ((I 0 (1+ I))) ((> I 10.))
    410 ;            (FORMAT T "~%~O" (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST)))
    411            (let ((tem (%unibus-read bit-count-register-test)))
     437;            (FORMAT T "~%~O" (%U-READ CONTROL-STATUS-REGISTER-TEST)))
     438           (let ((tem (%u-read bit-count-register-test)))
    412439             (if (= tem 7777)                   ;Null packet "received"
    413440                 (setq m-ones (1+ m-ones))
    414441                 (setq others (1+ others))))
    415                (%unibus-write control-status-register-test 14)))))
     442               (%u-write control-status-register-test 14)))))
    416443
    417444
     
    433460        (SI:MAKE-24-BIT-UNSIGNED (+ 77400000 (LSH ADDR -1))))  ; SET THE A MEMORY LOCATION
    434461  (INITIALIZE-NCP-SYSTEM)
    435   (%UNIBUS-WRITE OLD-CSR 20010)                 ;avoid interrupt hang screw
    436   (%UNIBUS-WRITE CONTROL-STATUS-REGISTER 20010)
     462  (%u-write OLD-CSR 20010)                      ;avoid interrupt hang screw
     463  (%u-write CONTROL-STATUS-REGISTER 20010)
    437464  (FORMAT NIL "NCP now using ~6O as the network interface base address." ADDR))
    438465
     
    440467(DEFUN TIMER-LOOP (&OPTIONAL (COUNT 511.) (SLEEP-TIME 1))
    441468  "Scope loop for looking at the interval timer."
    442   (DO NIL ((KBD-TYI-NO-HANG))
    443     (%UNIBUS-WRITE INTERVAL-TIMER-REGISTER-TEST COUNT)
     469  (DO NIL ((FUNCALL TERMINAL-IO ':TYI-NO-HANG))
     470    (%u-write INTERVAL-TIMER-REGISTER-TEST COUNT)
    444471    (PROCESS-SLEEP SLEEP-TIME)))
     472
     473(DEFUN %U-READ (ADR)
     474  (IF CHATST-USE-DEBUG
     475      (CADR:DBG-READ ADR)
     476      (%UNIBUS-READ ADR)))
     477
     478(DEFUN %U-WRITE (ADR DATA)
     479  (IF CHATST-USE-DEBUG
     480      (CADR:DBG-WRITE ADR DATA)
     481      (%UNIBUS-WRITE ADR DATA)))
     482
     483(SET-BASE-ADDRESS)
  • trunk/lisp/lmio1/ctest.lisp

    r253 r288  
    33;work rotation xfrm
    44
    5 (DEFCONST CTEST-BOARD-TYPE 'LG684)  ;OR MPG216
     5(DEFCONST CTEST-BOARD-TYPE 'MPG216)  ;OR LG684
    66
    77;Continuity Tester Interface
     
    690690;RETEST BAD RUNS.  NOTE THEY ARE IN TEXT FORM
    691691(DEFUN CTEST-RETEST-BAD-RUNS (&OPTIONAL (BAD-RUNS CTEST-BAD-RUNS))
     692  (SETQ CTEST-OLD-BAD-RUNS CTEST-BAD-RUNS)
     693  (SETQ CTEST-BAD-RUNS NIL)
    692694  (CTEST-TRY-TESTING 0 (MAPCAR (FUNCTION CTEST-UNCONVERT-RUN)
    693695                               (MAPCAR (FUNCTION CAR) BAD-RUNS))))
     
    749751        (SETQ LOC-LIST (CADR RUN) SEG-NO 0)
    750752   L    (COND ((NULL (CDR LOC-LIST))
    751                (RETURN (LIST (CTEST-CONVERT-RUN RUN) ANS)))
    752               ((TEST-WIRE (LIST (CAR RUN) (SETQ SEG-NO (1+ SEG-NO)))
     753               (RETURN (LIST (CTEST-CONVERT-RUN RUN) ANS))))
     754        (SETQ SEG-NO (1+ SEG-NO))
     755        (COND ((TEST-WIRE (CAR RUN)
    753756                          (CAR LOC-LIST)
    754757                          (CADR LOC-LIST))
  • trunk/lisp/lmio1/eftp.lisp

    r252 r288  
    1 ;-*- Mode:LISP; Package:CHAOS -*-
     1;-*- Mode:LISP; Package:CHAOS; Base:8 -*-
    22
    33;This file implements EFTP on the Lisp machine,
    4 ;with the cooperation of CHSNCP.
    5 
    6 ;Note, some of these 22.'s are 10.+12., the sum of the Muppet header size
    7 ;and the PUP header size.  Other 22.'s are 2.*11., the number of non-data bytes
    8 ;in a PUP.
    9 
    10 (DEFVAR PUP-INT-PKT NIL)        ;NIL or INT-PKT containing a PUP just received
    11 (DEFVAR PUP-INT-PKT-PORT NIL)   ;NIL or port expecting a packet
    12 (DEFVAR NEXT-LOCAL-PORT 1000)   ;Used to generate unique port numbers
    13 (DEFVAR MAX-PUP-DATA-BYTES 458.)        ;480-22
    14 
    15 ;Kludge since the CHSNCP doesn't currently pay any attention to routing information
    16 ;broadcast on the net.
    17 (ASET 426 ROUTING-TABLE 2)
    18 
    19 ;Structure of a PUP in a Muppet in an INT-PKT
    20 (DEFSTRUCT (PUP :ARRAY (:CONSTRUCTOR NIL))
    21   ((MUPPET-VERSION 0010) (MUPPET-PROTOCOL 1010))
    22   ((MUPPET-FORWARD-COUNT 0010) (MUPPET-MISC-BYTE 1010))
    23   (MUPPET-DEST-HOST)
    24   (MUPPET-DEST-PORT)
    25   (MUPPET-SOURCE-HOST)
    26   (MUPPET-SOURCE-PORT)
    27   (MUPPET-PACKET-NUMBER)
    28   (MUPPET-DATA-LENGTH)
    29   (MUPPET-FRAGMENT-POSITION)
    30   (MUPPET-FRAGMENT-LENGTH)
    31   (MUPPET-MISC-WORD)
    32   (MUPPET-CHECKSUM)
     4;with the cooperation of CHSNCP, using the Chaosnet foreign-protocol protocol.
     5
     6(DEFCONST PUP-NON-DATA-BYTES 22.)       ;10. words of header and a checksum
     7(DEFCONST MAX-PUP-DATA-BYTES (- MAX-DATA-BYTES-PER-PKT PUP-NON-DATA-BYTES))
     8(DEFCONST PUP-PROTOCOL-ID 100001)
     9
     10;Structure of a PUP in a Chaosnet packet
     11;Cannot use (:INCLUDE PKT) because PKT defstruct has some garbage at the end
     12(DEFSTRUCT (PUP :ARRAY (:CONSTRUCTOR NIL)
     13                (:INITIAL-OFFSET #.FIRST-DATA-WORD-IN-PKT) (:SIZE-SYMBOL PUP-FIRST-DATA-WORD))
    3314  (PUP-OVERALL-LENGTH)
    3415  ((PUP-TYPE 0010) (PUP-TRANSPORT 1010))
     
    4021  (PUP-SOURCE-HOST)
    4122  (PUP-SOURCE-PORT-HIGH)
    42   (PUP-SOURCE-PORT-LOW)
    43   ;Word 22. is the first data word.  Pup checksum after the data
    44   )
    45 
    46 
    47 ;Get a PUP buffer which can be filled in then transmitted
    48 (DEFUN GET-PUP (DEST-HOST DEST-PORT SOURCE-PORT
    49                 PUP-TYPE PUP-ID
    50                 &AUX (INT-PKT (ALLOCATE-INT-PKT)))
    51   (FILLARRAY INT-PKT '(0))
    52   (SETF (MUPPET-VERSION INT-PKT) 1)
    53   (SETF (MUPPET-PROTOCOL INT-PKT) 3)
    54   (SETF (MUPPET-DEST-HOST INT-PKT) DEST-HOST)
    55   (SETF (MUPPET-DEST-PORT INT-PKT) (LDB 0020 DEST-PORT))
    56   (SETF (MUPPET-SOURCE-HOST INT-PKT) MY-ADDRESS)
    57   (SETF (MUPPET-SOURCE-PORT INT-PKT) SOURCE-PORT)
    58   (SETF (MUPPET-PACKET-NUMBER INT-PKT) PUP-ID)
    59   (SETF (MUPPET-CHECKSUM INT-PKT) -1)           ;None
    60   (SETF (PUP-TYPE INT-PKT) PUP-TYPE)
    61   (SETF (PUP-ID-HIGH INT-PKT) (LDB 2020 PUP-ID))
    62   (SETF (PUP-ID-LOW INT-PKT) (LDB 0020 PUP-ID))
    63   (SETF (PUP-DEST-HOST INT-PKT) DEST-HOST)
    64   (SETF (PUP-DEST-PORT-HIGH INT-PKT) (LDB 2020 DEST-PORT))
    65   (SETF (PUP-DEST-PORT-LOW INT-PKT) (LDB 0020 DEST-PORT))
    66   (SETF (PUP-SOURCE-HOST INT-PKT) MY-ADDRESS)
    67   (SETF (PUP-SOURCE-PORT-LOW INT-PKT) SOURCE-PORT)
    68   INT-PKT)
     23  (PUP-SOURCE-PORT-LOW))        ;Data follow, then checksum
     24
     25
     26;Get a PUP buffer which can be filled in then transmitted via TRANSMIT-PUP
     27(DEFUN GET-PUP (CONN PUP-TYPE PUP-ID
     28                &AUX (PKT (GET-PKT)))
     29  (COPY-ARRAY-PORTION PKT 0 0 PKT 0 (ARRAY-LENGTH PKT)) ;Clear to zero
     30  (SETF (PUP-TYPE PKT) PUP-TYPE)
     31  (SETF (PUP-ID-HIGH PKT) (LDB 2020 PUP-ID))
     32  (SETF (PUP-ID-LOW PKT) (LDB 0020 PUP-ID))
     33  (SETF (PUP-DEST-HOST PKT) (FOREIGN-ADDRESS CONN))
     34  (SETF (PUP-DEST-PORT-HIGH PKT) (LDB 2020 (FOREIGN-INDEX-NUM CONN)))
     35  (SETF (PUP-DEST-PORT-LOW PKT) (LDB 0020 (FOREIGN-INDEX-NUM CONN)))
     36  (SETF (PUP-SOURCE-HOST PKT) MY-ADDRESS)
     37  (SETF (PUP-SOURCE-PORT-LOW PKT) (LOCAL-INDEX-NUM CONN))
     38  PKT)
     39
     40;The header of a PUP is words and the data portion is bytes.
     41;The bytes are already in Lisp machine order, but the header needs to be fixed.
     42(DEFUN SWAB-PUP (PUP)
     43  (LOOP FOR I FROM FIRST-DATA-WORD-IN-PKT BELOW PUP-FIRST-DATA-WORD
     44        AS WD = (AREF PUP I)
     45        DO (ASET (DPB WD 1010 (LDB 1010 WD)) PUP I))
     46  PUP)
     47
     48;Accessor for binary data in a PUP
     49(DEFUN PUP-WORD (PUP I)
     50  (LET ((WD (AREF PUP (+ PUP-FIRST-DATA-WORD I))))
     51    (DPB WD 1010 (LDB 1010 WD))))
     52
     53(DEFPROP PUP-WORD ((PUP-WORD PUP I) . (PUP-STORE-WORD PUP I SI:VAL)) SETF)
     54(DEFUN PUP-STORE-WORD (PUP I WD)
     55  (ASET (DPB WD 1010 (LDB 1010 WD)) PUP (+ PUP-FIRST-DATA-WORD I)))
    6956
    7057;Compute the checksum of a PUP
    71 (DEFUN CHECKSUM-PUP (INT-PKT)
    72   (DO ((I 12. (1+ I))
     58(DEFUN CHECKSUM-PUP (PKT)
     59  (DO ((I -10. (1+ I))
    7360       (CK 0)
    74        (N (LSH (1- (PUP-OVERALL-LENGTH INT-PKT)) -1) (1- N)))
     61       (N (LSH (1- (PKT-NBYTES PKT)) -1) (1- N)))
    7562      ((ZEROP N)
    7663       (AND (= CK 177777) (SETQ CK 0))          ;Gronk minus zero
    7764       (RETURN CK I))                           ;Return checksum and index in PUP of cksm
    78     (SETQ CK (+ CK (AREF INT-PKT I)))           ;1's complement add
     65    (SETQ CK (+ CK (PUP-WORD PKT I)))           ;1's complement add
    7966    (AND (BIT-TEST 200000 CK) (SETQ CK (LDB 0020 (1+ CK))))
    8067    (SETQ CK (DPB CK 0117 (LDB 1701 CK)))))     ;16-bit left rotate
    8168
    8269;Fire off a PUP previously gotten from GET-PUP
    83 (DEFUN TRANSMIT-PUP (INT-PKT N-BYTES)
    84   (SETF (MUPPET-DATA-LENGTH INT-PKT) (+ 22. N-BYTES))
    85   (SETF (PUP-OVERALL-LENGTH INT-PKT) (+ 22. N-BYTES))
    86   (MULTIPLE-VALUE-BIND (CKSM CKSMX) (CHECKSUM-PUP INT-PKT)
    87     (ASET CKSM INT-PKT CKSMX)
    88     (ASET (AREF ROUTING-TABLE (LDB 1010 (MUPPET-DEST-HOST INT-PKT))) INT-PKT (1+ CKSMX))
    89     (SETF (INT-PKT-WORD-COUNT INT-PKT) (+ CKSMX 2))
    90     (OR (= (%AREA-NUMBER INT-PKT) CHAOS-BUFFER-AREA)
    91         (FERROR NIL "Attempt to transmit non-interrupt packet ~A" INT-PKT))
    92     (WITHOUT-INTERRUPTS                         ;Ah, modularity, wonderful modularity.
    93      (PROG (OLD-TRANSMIT-LIST)
    94          (SETQ PKTS-TRANSMITTED (1+ PKTS-TRANSMITTED))
    95       LOOP
    96          (SETQ OLD-TRANSMIT-LIST (INT-TRANSMIT-LIST))
    97          (SETF (INT-PKT-THREAD INT-PKT) OLD-TRANSMIT-LIST)
    98          (OR (%STORE-CONDITIONAL INT-TRANSMIT-LIST-POINTER OLD-TRANSMIT-LIST INT-PKT)
    99              (GO LOOP))
    100          (%CHAOS-WAKEUP)))))
     70(DEFUN TRANSMIT-PUP (CONN PKT N-BYTES)
     71  (SETF (PKT-NBYTES PKT) (+ PUP-NON-DATA-BYTES N-BYTES))
     72  (SETF (PUP-OVERALL-LENGTH PKT) (+ PUP-NON-DATA-BYTES N-BYTES))
     73  (SETF (PKT-ACK-NUM PKT) PUP-PROTOCOL-ID)
     74  (SWAB-PUP PKT)
     75  (MULTIPLE-VALUE-BIND (CKSM CKSMX) (CHECKSUM-PUP PKT)
     76    (SETF (PUP-WORD PKT CKSMX) CKSM))
     77  (SEND-UNC-PKT CONN PKT)
     78  (SWAB-PUP PKT))       ;Put back in case caller retransmits it
    10179
    10280;Internal routine to get back a PUP on a specified port, with timeout
    103 ;Returns INT-PKT or NIL.
    104 (DEFUN RECEIVE-PUP (PORT &OPTIONAL (TIMEOUT 60.)
    105                     &AUX (START-TIME (TIME)) PUP)
    106   (UNWIND-PROTECT
    107     (DO () ((OR PUP-INT-PKT (> (TIME-DIFFERENCE (TIME) START-TIME) TIMEOUT))
    108             (WITHOUT-INTERRUPTS
    109               (SETQ PUP PUP-INT-PKT
    110                     PUP-INT-PKT NIL))
    111             (AND PUP
    112                  (MULTIPLE-VALUE-BIND (CKSM CKSMX) (CHECKSUM-PUP PUP)
    113                    (OR (= (AREF PUP CKSMX) 177777)
    114                        (= (AREF PUP CKSMX) CKSM)
    115                        (PROGN (FREE-INT-PKT PUP)
    116                               (SETQ PUP NIL)))))
    117             PUP)
    118       (SETQ PUP-INT-PKT-PORT PORT)
    119       (PROCESS-WAIT "PUP in" #'(LAMBDA (START-TIME TIMEOUT)
    120                                  (OR PUP-INT-PKT
    121                                      (> (TIME-DIFFERENCE (TIME) START-TIME) TIMEOUT)))
    122                              START-TIME TIMEOUT))
    123     (SETQ PUP-INT-PKT-PORT NIL)))
     81;Returns PKT or NIL.
     82(DEFUN RECEIVE-PUP (CONN &OPTIONAL (TIMEOUT 60.))
     83  (LOOP WITH START-TIME = (TIME)
     84        AS PUP = (GET-NEXT-PKT CONN T)
     85        WHEN PUP
     86          IF (AND (= (PKT-OPCODE PUP) UNC-OP)
     87                  (= (PKT-ACK-NUM PUP) PUP-PROTOCOL-ID)
     88                  (MULTIPLE-VALUE-BIND (CKSM CKSMX) (CHECKSUM-PUP PUP)
     89                    (LET ((CK (PUP-WORD PUP CKSMX)))
     90                      (OR (= CK 177777) (= CK CKSM)))))
     91          RETURN (SWAB-PUP PUP)
     92          ELSE DO (RETURN-PKT PUP)
     93        DO (PROCESS-WAIT "PUP in"
     94                         #'(LAMBDA (CONN START-TIME TIMEOUT)
     95                             (OR (READ-PKTS CONN)
     96                                 (> (TIME-DIFFERENCE (TIME) START-TIME) TIMEOUT)))
     97                         CONN START-TIME TIMEOUT)
     98        UNTIL (> (TIME-DIFFERENCE (TIME) START-TIME) TIMEOUT)))
    12499
    125100;Cons a string containing characters taken from a PUP
    126 (DEFUN PUP-STRING (PUP &OPTIONAL (FROM 0) (TO (- (PUP-OVERALL-LENGTH PUP) 22.)))
    127   (LET ((STR (MAKE-ARRAY NIL 'ART-STRING (MAX (- TO FROM) 0))))
    128     (DO ((I FROM (1+ I))
    129          (J 0 (1+ J))
    130          (WD))
    131         ((
    132  I TO))
    133       (SETQ WD (AREF PUP (+ (// I 2) 22.)))
    134       (ASET (LDB (IF (ODDP I) 0010 1010) WD) STR J))
    135     STR))
    136 
    137 (DEFUN GET-PORT-NUMBER ()
    138   (WITHOUT-INTERRUPTS (PROG1 NEXT-LOCAL-PORT
    139                              (SETQ NEXT-LOCAL-PORT (1+ NEXT-LOCAL-PORT))
    140                              (AND (> NEXT-LOCAL-PORT 177777)
    141                                   (SETQ NEXT-LOCAL-PORT 1000)))))
    142 
    143 ;Complain about random PUP we may have received, and free the INT-PKT
     101(DEFUN PUP-STRING (PUP &OPTIONAL (FROM 0) (TO (- (PUP-OVERALL-LENGTH PUP)
     102                                                 PUP-NON-DATA-BYTES)))
     103  (SUBSTRING (PKT-STRING PUP) (+ 20. FROM) (+ 20. TO))) ;20. is bytes in pup header
     104
     105;Complain about random PUP we may have received, and free the PKT
    144106;Put a trace breakpoint on this if you are trying to figure out what's going on.
    145107(DEFUN RECEIVED-RANDOM-PUP (PUP)
     
    151113          (DPB (PUP-SOURCE-PORT-HIGH PUP) 2020 (PUP-SOURCE-PORT-LOW PUP))
    152114          (= (PUP-TYPE PUP) 4)          ;Error
    153           (AREF PUP 32.)                ;Standard code
    154           (AREF PUP 33.)                ;Misc argument to it
     115          (PUP-WORD PUP 10.)            ;Standard code
     116          (PUP-WORD PUP 11.)            ;Misc argument to it
    155117          (PUP-STRING PUP 24.))         ;Human readable text
    156   (FREE-INT-PKT PUP)
    157   (KBD-CHAR-AVAILABLE))                 ;Chance to hit call
     118  (RETURN-PKT PUP))
    158119
    159120
    160121;EFTP-write stream.
    161122(DEFVAR EFTP-NEXT-PUP-ID)
    162 (DEFVAR EFTP-FOREIGN-HOST)
    163 (DEFVAR EFTP-FOREIGN-PORT)
    164 (DEFVAR EFTP-LOCAL-PORT)
     123(DEFVAR EFTP-CONN)
    165124(DEFVAR EFTP-BINARY-P)
    166125(DEFVAR EFTP-BUFFER)
    167126
    168 (DEFUN MAKE-EFTP-WRITE-STREAM (EFTP-FOREIGN-HOST
    169                                &OPTIONAL (EFTP-BINARY-P NIL) (EFTP-FOREIGN-PORT 20))
     127(DEFUN MAKE-EFTP-WRITE-STREAM (FOREIGN-HOST
     128                               &OPTIONAL (EFTP-BINARY-P NIL) (FOREIGN-PORT 20))
    170129  (LET ((EFTP-NEXT-PUP-ID 0)
    171         (EFTP-LOCAL-PORT (GET-PORT-NUMBER))
    172         (EFTP-BUFFER (MAKE-ARRAY NIL 'ART-8B MAX-PUP-DATA-BYTES NIL '(0))))
    173     (CLOSURE '(EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-NEXT-PUP-ID
    174                EFTP-LOCAL-PORT EFTP-BINARY-P EFTP-BUFFER)
     130        (EFTP-BUFFER (MAKE-ARRAY MAX-PUP-DATA-BYTES ':TYPE 'ART-8B ':LEADER-LIST '(0)))
     131        (EFTP-CONN (OPEN-FOREIGN-CONNECTION FOREIGN-HOST FOREIGN-PORT)))
     132    (CLOSURE '(EFTP-NEXT-PUP-ID EFTP-CONN EFTP-BINARY-P EFTP-BUFFER)
    175133             'EFTP-WRITE-STREAM)))
    176134
     
    208166                 (PUP))
    209167                (NIL)
    210               (SETQ PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-LOCAL-PORT 32 ID))
    211               (TRANSMIT-PUP PUP 0)
    212               (COND ((NULL (SETQ PUP (RECEIVE-PUP EFTP-LOCAL-PORT)))
     168              (SETQ PUP (GET-PUP EFTP-CONN 32 ID))
     169              (TRANSMIT-PUP EFTP-CONN PUP 0)
     170              (COND ((NULL (SETQ PUP (RECEIVE-PUP EFTP-CONN)))
    213171                     (AND (ZEROP (\ N-RETRANSMISSIONS 10.))
    214172                          (FORMAT ERROR-OUTPUT
    215                                   "~&[Host not responding to EFTP_End, still trying...]~%"))
    216                      (KBD-CHAR-AVAILABLE))
     173                                  "~&[Host not responding to EFTP_End, still trying...]~%")))
    217174                    ((= (PUP-TYPE PUP) 33)
    218175                     (FORMAT ERROR-OUTPUT "~&EFTP Abort in EFTP_End, code ~D, ~A~%"
    219                              (AREF PUP 22.) (PUP-STRING PUP 2))
    220                      (FREE-INT-PKT PUP)
     176                             (PUP-WORD PUP 0) (PUP-STRING PUP 2))
     177                     (RETURN-PKT PUP)
    221178                     (BREAK EFTP-ABORT))
    222179                    ((NOT (= (PUP-TYPE PUP) 31))
    223180                     (RECEIVED-RANDOM-PUP PUP))
    224181                    ((NOT (= (DPB (PUP-ID-HIGH PUP) 2020 (PUP-ID-LOW PUP)) ID))
    225                      (FREE-INT-PKT PUP))                ;Ignore random old acks
    226                     (T (FREE-INT-PKT PUP)
     182                     (RETURN-PKT PUP))          ;Ignore random old acks
     183                    (T (RETURN-PKT PUP)         ;Good ack
    227184                       (RETURN NIL))))
    228             (TRANSMIT-PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT
    229                                    EFTP-LOCAL-PORT 32 EFTP-NEXT-PUP-ID) 0))
     185            (TRANSMIT-PUP EFTP-CONN (GET-PUP EFTP-CONN 32 EFTP-NEXT-PUP-ID) 0)
     186            (REMOVE-CONN EFTP-CONN))
    230187    (OTHERWISE (STREAM-DEFAULT-HANDLER #'EFTP-WRITE-STREAM OP ARG1 ARGS))))
    231188
     
    236193            (PUP))
    237194           (NIL)
    238          (SETQ PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-LOCAL-PORT 30 ID))
     195         (SETQ PUP (GET-PUP EFTP-CONN 30 ID))
    239196         (DOTIMES (I (// (1+ (ARRAY-ACTIVE-LENGTH EFTP-BUFFER)) 2))
    240            (ASET (+ (LSH (AREF EFTP-BUFFER (* I 2)) 8) (AREF EFTP-BUFFER (1+ (* I 2))))
    241                  PUP (+ I 22.)))
    242          (TRANSMIT-PUP PUP (ARRAY-ACTIVE-LENGTH EFTP-BUFFER))
    243          (COND ((NULL (SETQ PUP (RECEIVE-PUP EFTP-LOCAL-PORT)))
     197           (ASET (DPB (AREF EFTP-BUFFER (1+ (* I 2))) 1010 (AREF EFTP-BUFFER (* I 2)))
     198                 PUP (+ I PUP-FIRST-DATA-WORD)))
     199         (TRANSMIT-PUP EFTP-CONN PUP (ARRAY-ACTIVE-LENGTH EFTP-BUFFER))
     200         (COND ((NULL (SETQ PUP (RECEIVE-PUP EFTP-CONN)))
    244201                (AND (ZEROP (\ N-RETRANSMISSIONS 10.))
    245                      (FORMAT ERROR-OUTPUT "~&[Host not responding, still trying...]~%"))
    246                 (KBD-CHAR-AVAILABLE))
     202                     (FORMAT ERROR-OUTPUT "~&[Host not responding, still trying...]~%")))
    247203               ((= (PUP-TYPE PUP) 33)
    248204                (FORMAT ERROR-OUTPUT "~&EFTP Abort code ~D, ~A~%"
    249                         (AREF PUP 22.) (PUP-STRING PUP 2))
    250                 (FREE-INT-PKT PUP)
     205                        (PUP-WORD PUP 0) (PUP-STRING PUP 2))
     206                (RETURN-PKT PUP)
    251207                (BREAK EFTP-ABORT))
    252208               ((NOT (= (PUP-TYPE PUP) 31))
    253209                (RECEIVED-RANDOM-PUP PUP))
    254210               ((NOT (= (DPB (PUP-ID-HIGH PUP) 2020 (PUP-ID-LOW PUP)) ID))
    255                 (FREE-INT-PKT PUP))             ;Ignore random old acks
    256                (T (FREE-INT-PKT PUP)
     211                (RETURN-PKT PUP))               ;Ignore random old acks
     212               (T (RETURN-PKT PUP)              ;Good ack
    257213                  (RETURN NIL)))))              ;Bingo!
    258214  (STORE-ARRAY-LEADER 0 EFTP-BUFFER 0)
    259215  T)
    260216
    261 (DEFUN EFTP-BINARY-FILE-TO-ALTO (FILENAME ALTO-ADDRESS)
    262   (LET ((IN (GLOBAL:OPEN FILENAME '(:READ :FIXNUM :BYTE-SIZE 8)))
    263         (OUT (MAKE-EFTP-WRITE-STREAM ALTO-ADDRESS T)))
    264     (STREAM-COPY-UNTIL-EOF IN OUT)
    265     (FUNCALL OUT ':CLOSE)
    266     (FUNCALL IN ':CLOSE)))
    267 
    268217
    269218(DEFVAR EFTP-UNRCHF)
    270219
    271 (DEFUN MAKE-EFTP-READ-STREAM (EFTP-FOREIGN-HOST
    272                                &OPTIONAL (EFTP-BINARY-P NIL) (EFTP-LOCAL-PORT 20))
     220(DEFUN MAKE-EFTP-READ-STREAM (FOREIGN-HOST
     221                               &OPTIONAL (EFTP-BINARY-P NIL) (LOCAL-PORT 20))
    273222  (LET ((EFTP-NEXT-PUP-ID 0)
    274         (EFTP-FOREIGN-PORT NIL) ;Set later
     223        (EFTP-CONN (OPEN-FOREIGN-CONNECTION FOREIGN-HOST 0 10. LOCAL-PORT))
    275224        (EFTP-UNRCHF NIL)
    276         (EFTP-BUFFER (MAKE-ARRAY NIL 'ART-8B MAX-PUP-DATA-BYTES NIL '(0 0))))
    277     (CLOSURE '(EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-UNRCHF EFTP-NEXT-PUP-ID
    278                EFTP-LOCAL-PORT EFTP-BINARY-P EFTP-BUFFER)
     225        (EFTP-BUFFER (MAKE-ARRAY MAX-PUP-DATA-BYTES ':TYPE 'ART-8B ':LEADER-LIST '(0 0))))
     226    (CLOSURE '(EFTP-CONN EFTP-UNRCHF EFTP-NEXT-PUP-ID EFTP-BINARY-P EFTP-BUFFER)
    279227             'EFTP-READ-STREAM)))
    280228
    281229(DEFUN EFTP-READ-STREAM (OP &OPTIONAL ARG1 &REST ARGS)
    282230  (SELECTQ OP
    283     (:WHICH-OPERATIONS '(:TYI :UNTYI))
     231    (:WHICH-OPERATIONS '(:TYI :UNTYI :CLOSE))
    284232    (:TYI (COND (EFTP-UNRCHF
    285233                  (PROG1 EFTP-UNRCHF (SETQ EFTP-UNRCHF NIL)))
     
    293241                                  (SETQ CH (EFTP-READ-STREAM OP ARG1))))))
    294242                    CH))
    295                 ((AND EFTP-FOREIGN-HOST (EFTP-READ-NEXT-PUP))
     243                ((AND EFTP-CONN (EFTP-READ-NEXT-PUP))
    296244                  (EFTP-READ-STREAM OP ARG1))
    297245                (T ;Eof
    298                   (SETQ EFTP-FOREIGN-HOST NIL)  ;Flag as eof
     246                  (REMOVE-CONN EFTP-CONN)
     247                  (SETQ EFTP-CONN NIL)          ;Flag as eof
    299248                  (AND ARG1 (ERROR ARG1)))))
    300249    (:UNTYI (SETQ EFTP-UNRCHF ARG1))
     250    (:CLOSE (REMOVE-CONN EFTP-CONN))
    301251    (OTHERWISE (STREAM-DEFAULT-HANDLER #'EFTP-READ-STREAM OP ARG1 ARGS))))
    302252
     
    304254  "Returns NIL at eof, else sets up buffer"
    305255  ;; EFTP-NEXT-PUP-ID has the number of the packet we are expecting to receive here
    306   (AND EFTP-FOREIGN-PORT                ;Not first time, acknowledge previous packet
    307        (TRANSMIT-PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-LOCAL-PORT
    308                               31 (1- EFTP-NEXT-PUP-ID)) 0))
     256  (AND (PLUSP EFTP-NEXT-PUP-ID)         ;Not first time, acknowledge previous packet
     257       (TRANSMIT-PUP EFTP-CONN (GET-PUP EFTP-CONN 31 (1- EFTP-NEXT-PUP-ID)) 0))
    309258  (DO ((N-TIMEOUTS 1 (1+ N-TIMEOUTS))
    310259       (EOF-SEQUENCE-P NIL)
    311260       (PUP))
    312261      (NIL)                             ;Loop until receive data
    313     (COND ((NULL (SETQ PUP (RECEIVE-PUP EFTP-LOCAL-PORT)))
     262    (COND ((NULL (SETQ PUP (RECEIVE-PUP EFTP-CONN)))
    314263           (COND ((ZEROP (\ N-TIMEOUTS 10.))
    315264                  (AND EOF-SEQUENCE-P (RETURN NIL))     ;Done with dally timeout
    316265                  (FORMAT ERROR-OUTPUT
    317                           (IF EFTP-FOREIGN-PORT
     266                          (IF (PLUSP EFTP-NEXT-PUP-ID)
    318267                              "~&[Host has stopped sending, still trying...]~%"
    319                               "~&[Host has not started sending, still trying...]~%"))))
    320            (KBD-CHAR-AVAILABLE))
     268                              "~&[Host has not started sending, still trying...]~%")))))
    321269          ((NOT (AND (OR (= (PUP-TYPE PUP) 30) (= (PUP-TYPE PUP) 32) (= (PUP-TYPE PUP) 33))
    322                      (= (PUP-SOURCE-HOST PUP) EFTP-FOREIGN-HOST)
    323                      (OR (NULL EFTP-FOREIGN-PORT)
     270                     (= (PUP-SOURCE-HOST PUP) (FOREIGN-ADDRESS EFTP-CONN))
     271                     (OR (ZEROP EFTP-NEXT-PUP-ID)
    324272                         (= (DPB (PUP-SOURCE-PORT-HIGH PUP) 2020 (PUP-SOURCE-PORT-LOW PUP))
    325                             EFTP-FOREIGN-PORT))))
     273                            (FOREIGN-INDEX-NUM EFTP-CONN)))))
    326274           (RECEIVED-RANDOM-PUP PUP))
    327275          ((= (PUP-TYPE PUP) 33)
    328276           (FORMAT ERROR-OUTPUT "~&EFTP Abort~:[~; in eof sequence~], code ~D, ~A~%"
    329                    EOF-SEQUENCE-P (AREF PUP 22.) (PUP-STRING PUP 2))
    330            (FREE-INT-PKT PUP)
     277                   EOF-SEQUENCE-P (PUP-WORD PUP 0) (PUP-STRING PUP 2))
     278           (RETURN-PKT PUP)
    331279           (BREAK EFTP-ABORT))
    332280          ((NOT (= (DPB (PUP-ID-HIGH PUP) 2020 (PUP-ID-LOW PUP))
    333281                   EFTP-NEXT-PUP-ID))
    334            (FREE-INT-PKT PUP)           ;Ignore random old data
    335            (AND EFTP-FOREIGN-PORT       ;Except repeat acknowledgement
    336                 (TRANSMIT-PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-LOCAL-PORT
    337                                        31 (1- EFTP-NEXT-PUP-ID)) 0)))
     282           (RETURN-PKT PUP)             ;Ignore random old data
     283           (AND (PLUSP EFTP-NEXT-PUP-ID);Except repeat acknowledgement
     284                (TRANSMIT-PUP EFTP-CONN (GET-PUP EFTP-CONN 31 (1- EFTP-NEXT-PUP-ID)) 0)))
    338285          ((= (PUP-TYPE PUP) 32)        ;Eof
    339            (FREE-INT-PKT PUP)
     286           (RETURN-PKT PUP)
    340287           (AND EOF-SEQUENCE-P (RETURN NIL))    ;Done dallying
    341288           (SETQ EOF-SEQUENCE-P T)      ;Ack the EFTP-END packet
    342            (TRANSMIT-PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-LOCAL-PORT
    343                                   31 EFTP-NEXT-PUP-ID) 0)
     289           (TRANSMIT-PUP EFTP-CONN (GET-PUP EFTP-CONN 31 EFTP-NEXT-PUP-ID) 0)
    344290           (SETQ EFTP-NEXT-PUP-ID (1+ EFTP-NEXT-PUP-ID)))
    345291          (T                            ;Incoming data
    346292           (AND (> N-TIMEOUTS 9)
    347293                (FORMAT ERROR-OUTPUT "~&[Host has commenced transmission]~%"))
    348            (AND (NULL EFTP-FOREIGN-PORT)
    349                 (SETQ EFTP-FOREIGN-PORT (DPB (PUP-SOURCE-PORT-HIGH PUP)
    350                                             2020 (PUP-SOURCE-PORT-LOW PUP))))
     294           (AND (ZEROP EFTP-NEXT-PUP-ID)
     295                (SETF (FOREIGN-INDEX-NUM EFTP-CONN)
     296                      (DPB (PUP-SOURCE-PORT-HIGH PUP) 2020 (PUP-SOURCE-PORT-LOW PUP))))
    351297           (SETF (ARRAY-LEADER EFTP-BUFFER 1) 0)
    352            (SETF (ARRAY-LEADER EFTP-BUFFER 0) (- (PUP-OVERALL-LENGTH PUP) 22.))
     298           (SETF (ARRAY-LEADER EFTP-BUFFER 0) (- (PUP-OVERALL-LENGTH PUP) PUP-NON-DATA-BYTES))
    353299           (DOTIMES (I (// (1+ (ARRAY-ACTIVE-LENGTH EFTP-BUFFER)) 2))
    354              (LET ((WD (AREF PUP (+ I 22.))))
    355                (ASET (LDB 1010 WD) EFTP-BUFFER (* I 2))
    356                (ASET (LDB 0010 WD) EFTP-BUFFER (1+ (* I 2)))))
    357            (FREE-INT-PKT PUP)
     300             (LET ((WD (AREF PUP (+ I PUP-FIRST-DATA-WORD))))
     301               (ASET (LDB 0010 WD) EFTP-BUFFER (* I 2))
     302               (ASET (LDB 1010 WD) EFTP-BUFFER (1+ (* I 2)))))
     303           (RETURN-PKT PUP)
    358304           (SETQ EFTP-NEXT-PUP-ID (1+ EFTP-NEXT-PUP-ID))
    359305           (RETURN T)))))
    360306
     307(DEFUN EFTP-BINARY-FILE-TO-ALTO (FILENAME ALTO-ADDRESS)
     308  (WITH-OPEN-FILE (IN FILENAME '(:READ :FIXNUM :BYTE-SIZE 8))
     309    (LET ((OUT (MAKE-EFTP-WRITE-STREAM ALTO-ADDRESS T)))
     310      (STREAM-COPY-UNTIL-EOF IN OUT)
     311      (FUNCALL OUT ':CLOSE))))
     312
    361313(DEFUN EFTP-BINARY-FILE-FROM-ALTO (FILENAME ALTO-ADDRESS)
    362   (LET ((OUT (GLOBAL:OPEN FILENAME '(:WRITE :FIXNUM :BYTE-SIZE 8)))
    363         (IN (MAKE-EFTP-READ-STREAM ALTO-ADDRESS T)))
    364     (STREAM-COPY-UNTIL-EOF IN OUT)
    365     (FUNCALL OUT ':CLOSE)))
    366 
     314  (WITH-OPEN-FILE (OUT FILENAME '(:WRITE :FIXNUM :BYTE-SIZE 8))
     315    (LET ((IN (MAKE-EFTP-READ-STREAM ALTO-ADDRESS T)))
     316      (STREAM-COPY-UNTIL-EOF IN OUT))))
    367317
    368318(DEFUN EFTP-TEXT-FILE-FROM-ALTO (FILENAME ALTO-ADDRESS)
    369   (LET ((OUT (GLOBAL:OPEN FILENAME '(:WRITE)))
    370         (IN (MAKE-EFTP-READ-STREAM ALTO-ADDRESS)))
    371     (STREAM-COPY-UNTIL-EOF IN OUT)
    372     (FUNCALL OUT ':CLOSE)))
     319  (WITH-OPEN-FILE (OUT FILENAME '(:WRITE))
     320    (LET ((IN (MAKE-EFTP-READ-STREAM ALTO-ADDRESS)))
     321      (STREAM-COPY-UNTIL-EOF IN OUT))))
    373322
    374323(DEFUN EFTP-TEXT-FILE-TO-ALTO (FILENAME ALTO-ADDRESS)
    375   (LET ((IN (GLOBAL:OPEN FILENAME '(:READ)))
    376         (OUT (MAKE-EFTP-WRITE-STREAM ALTO-ADDRESS)))
    377     (STREAM-COPY-UNTIL-EOF IN OUT)
    378     (FUNCALL IN ':CLOSE)
    379     (FUNCALL OUT ':CLOSE)))
     324  (WITH-OPEN-FILE (IN FILENAME '(:READ))
     325    (LET ((OUT (MAKE-EFTP-WRITE-STREAM ALTO-ADDRESS)))
     326      (STREAM-COPY-UNTIL-EOF IN OUT)
     327      (FUNCALL OUT ':CLOSE))))
     328
  • trunk/lisp/lmio1/fntcnv.lisp

    r253 r288  
    1 ;;;-*-Mode:LISP; Package:FED-*-
     1;;; -*-Mode:LISP; Package:FED; Base:8-*-
     2;;;  * (c) Copyright 1980 Massachusetts Institute of Technology **
     3;;;  * Enhancements (c) copyright 1981 Symbolics, Inc. **
    24
    35;The functions in this file
    46;are used to convert between the various formats for fonts as used on the LISP
    5 ;Machine.  There are currently three formats supported:
     7;Machine.  These are the formats currently supported in some way:
    68;       KST format is used for communication with the PDP-10.
    79;       FD (or Font Descriptor) Format is used as a machine resident format
    810;               which is easily manipulated.  The format consists of a 200
    9 ;               element array with a leader.  The elements of this array are
     11;               or more element array with a leader.  The elements of this array are
    1012;               themselves two dimensional arrays which contain the actual
    1113;               pixel values for the character.
     
    1517;               be better.
    1618;       AL format is used for ALTO fonts.
     19;       AC another xerox format.
     20;       KS kerned strike xerox format.
     21;       AST stars and spaces.
     22
     23;Conversion functions:
     24; FONT-INTO-FONT-DESCRIPTOR FONTNAME => FONT-DESCRIPTOR
     25;  (you might really want FONT-NAME-FONT-DESCRIPTOR, which remembers the FONT-DESCRIPTOR)
     26; FONT-DESCRIPTOR-INTO-FONT FONT-DESCRIPTOR => FONTNAME
     27; READ-X-INTO-FONT FILENAME &OPTIONAL FONTNAME => FONTNAME
     28; READ-X-INTO-FONT-DESCRIPTOR FILENAME &OPTIONAL FONTNAME => FONT-DESCRIPTOR
     29; WRITE-FONT-INTO-X FONTNAME &OPTIONAL FILENAME => OUTPUT-TRUENAME
     30; WRITE-FONT-DESCRIPTOR-INTO-X FONT-DESCRIPTOR &OPTIONAL FILENAME => OUTPUT-TRUENAME
     31
     32;Other useful functions in here:
     33; THICKEN-FONT[-DESCRIPTOR], makes B(old) fonts.
     34; ROTATE-FONT[-DESCRIPTOR], makes R(otated) fonts.  I.e. landscape from portrait.
     35
     36; CD-RASTER-RANGE CHAR-DESCRIPTOR => MINX MINY MAXX MAXY
     37; CD-UNUSED-RASTER-HEIGHT CHAR-DESCRIPTOR => BOTTOM TOP
     38
    1739
    1840;First some helping functions:
     
    2042;Maximum raster width of an FD format font
    2143(DEFUN MAX-RASTER-WIDTH (FONT-DESCRIPTOR &AUX (GUESS 0) TEMP)
    22        (DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
    23            ((
    24  CHAR-CODE 200) GUESS)
    25            (COND ((SETQ TEMP (AR-1 FONT-DESCRIPTOR CHAR-CODE))
    26                   (SETQ GUESS (MAX GUESS (ARRAY-DIMENSION-N 2 TEMP)))))))
     44  (DO ((CHAR-CODE 0 (1+ CHAR-CODE))
     45       (FONT-LENGTH (ARRAY-ACTIVE-LENGTH FONT-DESCRIPTOR)))
     46      ((
     47 CHAR-CODE FONT-LENGTH) GUESS)
     48    (COND ((SETQ TEMP (AREF FONT-DESCRIPTOR CHAR-CODE))
     49           (SETQ GUESS (MAX GUESS (ARRAY-DIMENSION-N 2 TEMP)))))))
    2750
    2851;Maximum raster height of an FD format font
    2952(DEFUN MAX-RASTER-HEIGHT (FONT-DESCRIPTOR &AUX (GUESS 0) TEMP)
    30        (DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
    31            ((
    32  CHAR-CODE 200) GUESS)
    33            (COND ((SETQ TEMP (AR-1 FONT-DESCRIPTOR CHAR-CODE))
    34                   (SETQ GUESS (MAX GUESS (ARRAY-DIMENSION-N 1 TEMP)))))))
     53  (DO ((CHAR-CODE 0 (1+ CHAR-CODE))
     54       (FONT-LENGTH (ARRAY-ACTIVE-LENGTH FONT-DESCRIPTOR)))
     55      ((
     56 CHAR-CODE FONT-LENGTH) GUESS)
     57    (COND ((SETQ TEMP (AREF FONT-DESCRIPTOR CHAR-CODE))
     58           (SETQ GUESS (MAX GUESS (ARRAY-DIMENSION-N 1 TEMP)))))))
    3559
    3660;;; Memoizing version of FONT-INTO-FONT-DESCRIPTOR
     
    3963;;; The FONT-DESCRIBED property holds the font itself which the descriptor matches.
    4064;;; If anyone changes the font, we can see that the old descriptor is no good.
    41 (defun font-name-font-descriptor (fontname &aux fd)
    42     (setq fd (get fontname 'font-descriptor))
    43     (cond ((and fd (eq (get fontname 'font-described) (symeval fontname))))
    44           (t (setq fd (font-into-font-descriptor (symeval fontname)))
    45              (putprop fontname (symeval fontname) 'font-described)
    46              (putprop fontname fd 'font-descriptor)))
    47     fd)
     65(DEFUN FONT-NAME-FONT-DESCRIPTOR (FONTNAME &AUX FD)
     66  (SETQ FD (GET FONTNAME 'FONT-DESCRIPTOR))
     67  (COND ((AND FD (EQ (GET FONTNAME 'FONT-DESCRIBED) (SYMEVAL FONTNAME))))
     68        (T (SETQ FD (FONT-INTO-FONT-DESCRIPTOR (SYMEVAL FONTNAME)))
     69           (PUTPROP FONTNAME (SYMEVAL FONTNAME) 'FONT-DESCRIBED)
     70           (PUTPROP FONTNAME FD 'FONT-DESCRIPTOR)))
     71  FD)
    4872
    4973;;; Set a font given a font descriptor.  Keep the descriptor around.
    5074;;; Forward the old definition of the font to the new one.
    51 (defun font-name-set-font-and-descriptor (fontname font-descriptor)
    52     (let ((oldfont (and (boundp fontname) (symeval fontname))))
    53       (set fontname (font-descriptor-into-font font-descriptor))
    54       (and oldfont (structure-forward oldfont (symeval fontname)))
    55       (putprop fontname font-descriptor 'font-descriptor)
    56       (putprop fontname (symeval fontname) 'font-described)
    57       font-descriptor))
     75(DEFUN FONT-NAME-SET-FONT-AND-DESCRIPTOR (FONTNAME FONT-DESCRIPTOR)
     76  (LET ((OLDFONT (AND (BOUNDP FONTNAME) (SYMEVAL FONTNAME))))
     77    (SET FONTNAME (FONT-DESCRIPTOR-INTO-FONT FONT-DESCRIPTOR))
     78    (AND OLDFONT (STRUCTURE-FORWARD OLDFONT (SYMEVAL FONTNAME)))
     79    (PUTPROP FONTNAME FONT-DESCRIPTOR 'FONT-DESCRIPTOR)
     80    (PUTPROP FONTNAME (SYMEVAL FONTNAME) 'FONT-DESCRIBED)
     81    FONT-DESCRIPTOR))
    5882
    5983;Store a character in a font.  Given a font and corresponding FD, both are
     
    6185;If the CD can be stored into the existing font, that is done.
    6286;Otherwise, a new font is made from the updated FD and the old font forwarded to it.
    63 (defun font-name-store-cd (fontname cd char-code &aux font)
    64     (let ((width (array-dimension-n 2 cd))
    65           (height (array-dimension-n 1 cd))
    66           tem fd)
    67       (setq fd (font-name-font-descriptor fontname))
    68       (as-1 cd fd char-code)
    69       (and (= char-code #/ )
    70            (setf (fd-space-width fd) (cd-char-width cd)))
    71       (cond ((or (not (boundp fontname))
    72                  (null (setq font (symeval fontname)))
    73                  (> width
    74                     (cond ((setq tem (font-indexing-table font))
    75                            (* (font-raster-width font)
    76                               (- (ar-1 tem (1+ char-code))
    77                                  (ar-1 tem char-code))))
    78                           (t (font-raster-width font))))
    79                  (> height (font-raster-height font)))
    80              (font-name-set-font-and-descriptor fontname fd))
    81             (t (store-cd-in-font cd font char-code nil)))))
     87(DEFUN FONT-NAME-STORE-CD (FONTNAME CD CHAR-CODE &AUX FONT)
     88  (LET ((WIDTH (ARRAY-DIMENSION-N 2 CD))
     89        (HEIGHT (ARRAY-DIMENSION-N 1 CD))
     90        TEM FD)
     91    (SETQ FD (FONT-NAME-FONT-DESCRIPTOR FONTNAME))
     92    (FD-STORE-CD FD CD CHAR-CODE)
     93    (AND (= CHAR-CODE #\SP)
     94         (SETF (FD-SPACE-WIDTH FD) (CD-CHAR-WIDTH CD)))
     95    (COND ((OR (NOT (BOUNDP FONTNAME))
     96               (NULL (SETQ FONT (SYMEVAL FONTNAME)))
     97               (
     98 CHAR-CODE (MAX (OR (FONT-FILL-POINTER FONT) 200) 200))
     99               (> WIDTH
     100                  (COND ((SETQ TEM (FONT-INDEXING-TABLE FONT))
     101                         (* (FONT-RASTER-WIDTH FONT)
     102                            (- (AREF TEM (1+ CHAR-CODE))
     103                               (AREF TEM CHAR-CODE))))
     104                        (T (FONT-RASTER-WIDTH FONT))))
     105               (> HEIGHT (FONT-RASTER-HEIGHT FONT)))
     106           (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME FD))
     107          (T (STORE-CD-IN-FONT CD FONT CHAR-CODE NIL)))))
     108
     109(DEFUN FD-STORE-CD (FD CD CH)
     110  (AND (
     111 CH (ARRAY-LENGTH FD))
     112       (ADJUST-ARRAY-SIZE FD (+ CH 100)))
     113  (AND (
     114 CH (FD-FILL-POINTER FD))
     115       (SETF (FD-FILL-POINTER FD) (1+ CH)))
     116  (ASET CD FD CH))
    82117
    83118
     
    89124;  (SETQ ROW (- (FONT-BASELINE FONT) ROW))
    90125;  (AND (SETQ TEM (FONT-LEFT-KERN-TABLE FONT))
    91 ;       (SETQ COL (+ COL (AR-1 TEM CHAR))))
     126;       (SETQ COL (+ COL (AREF TEM CHAR))))
    92127;However it looks like this would cause more trouble than it would save.
    93128;Attempts to reference outside of the raster return 0, or barf if storing.
     
    96131(DEFUN FONT-GET-PIXEL (FONT CHAR ROW COL &AUX TEM (NEXTCHAR (1+ CHAR)))
    97132  (COND ((OR (< ROW 0)
    98              (>= ROW (FONT-RASTER-HEIGHT FONT))
     133             (
     134 ROW (FONT-RASTER-HEIGHT FONT))
    99135             (< COL 0)
    100136             (COND ((SETQ TEM (FONT-INDEXING-TABLE FONT))
    101                     (SETQ CHAR (+ (AR-1 TEM CHAR) (// COL (FONT-RASTER-WIDTH FONT))))
     137                    (SETQ CHAR (+ (AREF TEM CHAR) (// COL (FONT-RASTER-WIDTH FONT))))
    102138                    (SETQ COL (\ COL (FONT-RASTER-WIDTH FONT)))
    103                     (>= CHAR (AR-1 TEM NEXTCHAR)))
    104                    ((>= COL (FONT-RASTER-WIDTH FONT)))))
    105          0)  ;out of bounds, return 0
     139                    (
     140 CHAR (AREF TEM NEXTCHAR)))
     141                   ((
     142 COL (FONT-RASTER-WIDTH FONT)))))
     143         0)     ;out of bounds, return 0
    106144        (T
    107145         (DO ((FONT FONT (FONT-NEXT-PLANE FONT))
     
    110148             ((NULL FONT) PIXEL)
    111149           (SETQ PIXEL
    112                  (+ PIXEL (LSH (AR-1 FONT
     150                 (+ PIXEL (LSH (AREF FONT
    113151                                     (+ (* 32. (+ (* (FONT-WORDS-PER-CHAR FONT) CHAR)
    114152                                                  (// ROW (FONT-RASTERS-PER-WORD FONT))))
     
    120158(DEFUN FONT-SET-PIXEL (PIXEL FONT CHAR ROW COL &AUX TEM (NEXTCHAR (1+ CHAR)))
    121159  (COND ((OR (< ROW 0)
    122              (>= ROW (FONT-RASTER-HEIGHT FONT))
     160             (
     161 ROW (FONT-RASTER-HEIGHT FONT))
    123162             (< COL 0)
    124163             (COND ((SETQ TEM (FONT-INDEXING-TABLE FONT))
    125                     (SETQ CHAR (+ (AR-1 TEM CHAR) (// COL (FONT-RASTER-WIDTH FONT))))
     164                    (SETQ CHAR (+ (AREF TEM CHAR) (// COL (FONT-RASTER-WIDTH FONT))))
    126165                    (SETQ COL (\ COL (FONT-RASTER-WIDTH FONT)))
    127                     (>= CHAR (AR-1 TEM NEXTCHAR)))
    128                    ((>= COL (FONT-RASTER-WIDTH FONT)))))
     166                    (
     167 CHAR (AREF TEM NEXTCHAR)))
     168                   ((
     169 COL (FONT-RASTER-WIDTH FONT)))))
    129170         (FERROR NIL "Store of ~C in ~S at ~O,~O out of character bounds" CHAR FONT ROW COL))
    130171        (T
     
    132173              (BIT PIXEL (LSH BIT -1)))
    133174             ((NULL FONT) PIXEL)
    134              (AS-1 BIT FONT
     175             (ASET BIT FONT
    135176                   (+ (* 32. (+ (* (FONT-WORDS-PER-CHAR FONT) CHAR)
    136177                                (// ROW (FONT-RASTERS-PER-WORD FONT))))
     
    146187
    147188(DEFUN FONT-DESCRIPTOR-INTO-FONT (FONT-DESCRIPTOR
    148            &OPTIONAL (NBR-PLANES-OUT NIL)
    149            &AUX (FONT-OUT NIL)
    150                 (COL-INCR (COND ((FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR) 2)
    151                                 (T 1)))
    152                 (SPACE-WIDTH (OR (FD-SPACE-WIDTH FONT-DESCRIPTOR) 0))
    153                 (WIDTH (// SPACE-WIDTH COL-INCR))
    154                 (HEIGHT (FD-LINE-SPACING FONT-DESCRIPTOR))
    155                 (BASELINE (FD-BASELINE FONT-DESCRIPTOR))
    156                 (RASTER-WIDTH (// (+ (MAX-RASTER-WIDTH FONT-DESCRIPTOR)
    157                                      (1- COL-INCR))
    158                                   COL-INCR))
    159                 (RASTER-HEIGHT (MAX-RASTER-HEIGHT FONT-DESCRIPTOR))
    160                 (RASTERS-PER-WORD (// 32. (MIN 32. RASTER-WIDTH)))
    161                 (WORDS-PER-RASTER-ELEMENT (1+ (// (1- RASTER-HEIGHT) RASTERS-PER-WORD)))
    162                 (TOTAL-RASTER-ELEMENTS 200)
    163                 (BLINKER-WIDTH (// (FD-BLINKER-WIDTH FONT-DESCRIPTOR) COL-INCR))
    164                 (BLINKER-HEIGHT (FD-BLINKER-HEIGHT FONT-DESCRIPTOR))
    165                 (INDEXING-TABLE NIL)
    166                 (CHARS-EXIST-TABLE (MAKE-ARRAY NIL ART-1B 200))
    167                 TEMP                                    ;General temporary
    168                 )
    169 
     189       &OPTIONAL (NBR-PLANES-OUT NIL)
     190       &AUX (FONT-OUT NIL)
     191            (FONT-DESCRIPTOR-LENGTH (ARRAY-ACTIVE-LENGTH FONT-DESCRIPTOR))
     192            (FONT-LENGTH (MAX FONT-DESCRIPTOR-LENGTH 200))
     193            (COL-INCR (COND ((FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR) 2)
     194                            (T 1)))
     195            (SPACE-WIDTH (OR (FIX (+ (FD-SPACE-WIDTH FONT-DESCRIPTOR) 0.5)) 0))
     196            (WIDTH (// SPACE-WIDTH COL-INCR))
     197            (HEIGHT (FD-LINE-SPACING FONT-DESCRIPTOR))
     198            (BASELINE (FD-BASELINE FONT-DESCRIPTOR))
     199            (RASTER-WIDTH (// (+ (MAX-RASTER-WIDTH FONT-DESCRIPTOR)
     200                                 (1- COL-INCR))
     201                              COL-INCR))
     202            (RASTER-HEIGHT (MAX-RASTER-HEIGHT FONT-DESCRIPTOR))
     203            (RASTERS-PER-WORD (// 32. (MIN 32. RASTER-WIDTH)))
     204            (WORDS-PER-RASTER-ELEMENT (1+ (// (1- RASTER-HEIGHT) RASTERS-PER-WORD)))
     205            (TOTAL-RASTER-ELEMENTS FONT-LENGTH)
     206            (BLINKER-WIDTH (// (FD-BLINKER-WIDTH FONT-DESCRIPTOR) COL-INCR))
     207            (BLINKER-HEIGHT (FD-BLINKER-HEIGHT FONT-DESCRIPTOR))
     208            (INDEXING-TABLE NIL)
     209            (CHARS-EXIST-TABLE (MAKE-ARRAY FONT-LENGTH ':TYPE 'ART-1B))
     210            TEMP                                ;General temporary
     211            )
     212 
    170213;Set up NBR-PLANES-OUT if defaulted
    171        (COND ((NULL NBR-PLANES-OUT)
    172               (SETQ NBR-PLANES-OUT COL-INCR)))
    173 
     214  (COND ((NULL NBR-PLANES-OUT)
     215         (SETQ NBR-PLANES-OUT COL-INCR)))
     216 
    174217;Create INDEXING-TABLE if needed
    175        (COND ((> RASTER-WIDTH 32.)
    176                 (SETQ INDEXING-TABLE (MAKE-ARRAY NIL 'ART-16B 201))
    177                 (AS-1 0 INDEXING-TABLE 0)
    178                 (DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
    179                     ((
    180  CHAR-CODE 200) (SETQ TOTAL-RASTER-ELEMENTS (AR-1 INDEXING-TABLE 200)))
    181                     (SETQ TEMP (AR-1 FONT-DESCRIPTOR CHAR-CODE))
    182                     (AS-1 (+ (AR-1 INDEXING-TABLE CHAR-CODE)
    183                              (COND ((NULL TEMP) 0)
    184                                    (T (// (+ (ARRAY-DIMENSION-N 2 TEMP) 31.) 32.))))
    185                           INDEXING-TABLE (1+ CHAR-CODE)))
    186                 (SETQ RASTER-WIDTH 32.)))
    187 
     218  (COND ((> RASTER-WIDTH 32.)
     219         (SETQ INDEXING-TABLE (MAKE-ARRAY (1+ FONT-LENGTH) ':TYPE 'ART-16B))
     220         (ASET 0 INDEXING-TABLE 0)
     221         (DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
     222             ((
     223 CHAR-CODE FONT-LENGTH)
     224              (SETQ TOTAL-RASTER-ELEMENTS (AREF INDEXING-TABLE FONT-LENGTH)))
     225           (SETQ TEMP (AND (< CHAR-CODE FONT-DESCRIPTOR-LENGTH)
     226                           (AREF FONT-DESCRIPTOR CHAR-CODE)))
     227           (ASET (+ (AREF INDEXING-TABLE CHAR-CODE)
     228                    (COND ((NULL TEMP) 0)
     229                          (T (// (+ (ARRAY-DIMENSION-N 2 TEMP) 31.) 32.))))
     230                 INDEXING-TABLE (1+ CHAR-CODE)))
     231         (SETQ RASTER-WIDTH 32.)))
     232 
    188233;set up all the planes of the font
    189        (DO ((I NBR-PLANES-OUT (1- I)))
    190            ((ZEROP I))
    191 
     234  (DO ((I NBR-PLANES-OUT (1- I)))
     235      ((ZEROP I))
     236   
    192237;Make up a (one-plane) font and make it's next plane be the last one we made
    193            (SETQ TEMP (TV:MAKE-FONT MAKE-ARRAY (NIL 'ART-1B
    194                                                     (* TOTAL-RASTER-ELEMENTS
    195                                                        WORDS-PER-RASTER-ELEMENT 32.))))
    196            (SETF (FONT-NEXT-PLANE TEMP) FONT-OUT)
    197            (SETQ FONT-OUT TEMP)
    198 
     238    (SETQ TEMP (TV:MAKE-FONT MAKE-ARRAY (:TYPE 'ART-1B
     239                                               :LENGTH (* TOTAL-RASTER-ELEMENTS
     240                                                          WORDS-PER-RASTER-ELEMENT 32.))))
     241    (SETF (FONT-NEXT-PLANE TEMP) FONT-OUT)
     242    (SETQ FONT-OUT TEMP)
     243   
    199244;Now set all the other fields in the leader
    200            (SETF (FONT-NAME FONT-OUT) (FD-NAME FONT-DESCRIPTOR))
    201            (SETF (FONT-CHAR-WIDTH FONT-OUT) WIDTH)
    202            (SETF (FONT-CHAR-HEIGHT FONT-OUT) HEIGHT)
    203            (SETF (FONT-RASTER-WIDTH FONT-OUT) RASTER-WIDTH)
    204            (SETF (FONT-RASTER-HEIGHT FONT-OUT) RASTER-HEIGHT)
    205            (SETF (FONT-RASTERS-PER-WORD FONT-OUT) RASTERS-PER-WORD)
    206            (SETF (FONT-WORDS-PER-CHAR FONT-OUT) WORDS-PER-RASTER-ELEMENT)
    207            (SETF (FONT-BASELINE FONT-OUT) BASELINE)
    208            (SETF (FONT-BLINKER-WIDTH FONT-OUT) BLINKER-WIDTH)
    209            (SETF (FONT-BLINKER-HEIGHT FONT-OUT) BLINKER-HEIGHT)
    210            (SETF (FONT-NAME FONT-OUT) (FD-NAME FONT-DESCRIPTOR))
    211            (SETF (FONT-CHARS-EXIST-TABLE FONT-OUT) CHARS-EXIST-TABLE)
    212            (SETF (FONT-INDEXING-TABLE FONT-OUT) INDEXING-TABLE))
    213        (DO ((CHAR-CODE 0 (1+ CHAR-CODE))) ((
    214  CHAR-CODE 200))
    215            (SETQ TEMP (AR-1 FONT-DESCRIPTOR CHAR-CODE))
    216            (COND (TEMP
    217                   (STORE-CD-IN-FONT TEMP FONT-OUT CHAR-CODE
    218                                     (FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR)))))
    219        FONT-OUT)
     245    (SETF (FONT-NAME FONT-OUT) (FD-NAME FONT-DESCRIPTOR))
     246    (SETF (FONT-CHAR-WIDTH FONT-OUT) WIDTH)
     247    (SETF (FONT-CHAR-HEIGHT FONT-OUT) HEIGHT)
     248    (SETF (FONT-RASTER-WIDTH FONT-OUT) RASTER-WIDTH)
     249    (SETF (FONT-RASTER-HEIGHT FONT-OUT) RASTER-HEIGHT)
     250    (SETF (FONT-RASTERS-PER-WORD FONT-OUT) RASTERS-PER-WORD)
     251    (SETF (FONT-WORDS-PER-CHAR FONT-OUT) WORDS-PER-RASTER-ELEMENT)
     252    (SETF (FONT-BASELINE FONT-OUT) BASELINE)
     253    (SETF (FONT-BLINKER-WIDTH FONT-OUT) BLINKER-WIDTH)
     254    (SETF (FONT-BLINKER-HEIGHT FONT-OUT) BLINKER-HEIGHT)
     255    (SETF (FONT-NAME FONT-OUT) (FD-NAME FONT-DESCRIPTOR))
     256    (SETF (FONT-CHARS-EXIST-TABLE FONT-OUT) CHARS-EXIST-TABLE)
     257    (SETF (FONT-INDEXING-TABLE FONT-OUT) INDEXING-TABLE)
     258    (SETF (FONT-FILL-POINTER FONT-OUT) FONT-LENGTH))
     259  (DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
     260      ((
     261 CHAR-CODE FONT-LENGTH))
     262    (SETQ TEMP (AND (< CHAR-CODE FONT-DESCRIPTOR-LENGTH)
     263                    (AREF FONT-DESCRIPTOR CHAR-CODE)))
     264    (COND (TEMP
     265           (STORE-CD-IN-FONT TEMP FONT-OUT CHAR-CODE
     266                             (FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR)))))
     267  FONT-OUT)
    220268
    221269
     
    224272;This is not recommended for users to call.
    225273(DEFUN STORE-CD-IN-FONT (CD FONT CHAR-CODE &OPTIONAL (DOUBLE-WIDTH-P NIL) &AUX
    226                             (WIDTH (ARRAY-DIMENSION-N 2 CD))
    227                             (HEIGHT (ARRAY-DIMENSION-N 1 CD))
    228                             (FONT-HEIGHT (FONT-RASTER-HEIGHT FONT))
    229                             (FONT-WIDTH (FONT-RASTER-WIDTH FONT))
    230                             PIXEL
    231                             (COL-INCR (COND (DOUBLE-WIDTH-P 2) (T 1))))
    232     ;; Update the font's char-width-table, creating one if necessary.
    233     (LET ((CW (// (+ (CD-CHAR-WIDTH CD)
    234                      (1- COL-INCR))
    235                   COL-INCR))
    236           (FCW (FONT-CHAR-WIDTH FONT))
    237           (FCWT (FONT-CHAR-WIDTH-TABLE FONT)))
    238         (COND (FCWT
    239                (AS-1 CW FCWT CHAR-CODE))
    240               ((NOT (= CW FCW))
    241                (SETF (FONT-CHAR-WIDTH-TABLE FONT)
    242                      (SETQ FCWT (MAKE-ARRAY NIL ART-8B '(200))))
    243                (AND DOUBLE-WIDTH-P
    244                     (SETF (FONT-CHAR-WIDTH-TABLE (FONT-NEXT-PLANE FONT))
    245                           FCWT))
    246                (DO I 0 (1+ I) (= I 200)
    247                   (AS-1 FCW FCWT I))
    248                (AS-1 CW FCWT CHAR-CODE)))
    249         (AND (= CHAR-CODE #/ )
    250              (SETF (FONT-CHAR-WIDTH FONT) CW)))
    251     ;; Update the font's left-kern table, creating one if necessary.
    252     (LET ((CK (CD-CHAR-LEFT-KERN CD))
    253           (FCKT (FONT-LEFT-KERN-TABLE FONT)))
    254         (COND (FCKT (AS-1 CK FCKT CHAR-CODE))
    255               ((NOT (ZEROP CK))
    256                (SETF (FONT-LEFT-KERN-TABLE FONT)        ;MUST BE ART-32B BECAUSE LEFT-KERN
    257                      (SETQ FCKT (MAKE-ARRAY NIL ART-32B '(200))))  ;CAN BE NEGATIVE
    258                (AND DOUBLE-WIDTH-P
    259                     (SETF (FONT-LEFT-KERN-TABLE (FONT-NEXT-PLANE FONT))
    260                           FCKT))
    261                (AS-1 CK FCKT CHAR-CODE))))
    262     ;; Tell the font this char exists.
    263     (ERRSET (AS-1 1 (FONT-CHARS-EXIST-TABLE FONT) CHAR-CODE) NIL)
    264     ;; In wide fonts, the raster width depends on the character, and is a multiple of 32.
    265     (COND ((FONT-INDEXING-TABLE FONT)
    266            (SETQ FONT-WIDTH (* (// (+ (ARRAY-DIMENSION-N 2 CD) 31.) 32.) 32.))))
    267     ;; Now copy the data.
    268     (DO ((ROW 0 (1+ ROW)))
     274                         (FONT-LENGTH (FONT-FILL-POINTER FONT))
     275                         (WIDTH (ARRAY-DIMENSION-N 2 CD))
     276                         (HEIGHT (ARRAY-DIMENSION-N 1 CD))
     277                         (FONT-HEIGHT (FONT-RASTER-HEIGHT FONT))
     278                         (FONT-WIDTH (FONT-RASTER-WIDTH FONT))
     279                         PIXEL
     280                         (COL-INCR (COND (DOUBLE-WIDTH-P 2) (T 1))))
     281  (OR (AND FONT-LENGTH (
     282 FONT-LENGTH 200))
     283      (SETQ FONT-LENGTH 200))
     284  ;; Update the font's char-width-table, creating one if necessary.
     285  (LET ((CW (// (+ (FIX (+ (CD-CHAR-WIDTH CD) 0.5))
     286                   (1- COL-INCR))
     287                COL-INCR))
     288        (FCW (FONT-CHAR-WIDTH FONT))
     289        (FCWT (FONT-CHAR-WIDTH-TABLE FONT)))
     290    (COND (FCWT
     291           (ASET CW FCWT CHAR-CODE))
     292          ((NOT (= CW FCW))
     293           (SETF (FONT-CHAR-WIDTH-TABLE FONT)
     294                 (SETQ FCWT (MAKE-ARRAY FONT-LENGTH ':TYPE 'ART-8B)))
     295           (AND DOUBLE-WIDTH-P
     296                (SETF (FONT-CHAR-WIDTH-TABLE (FONT-NEXT-PLANE FONT))
     297                      FCWT))
     298           (DO I 0 (1+ I) (= I FONT-LENGTH)
     299               (ASET FCW FCWT I))
     300           (ASET CW FCWT CHAR-CODE)))
     301    (AND (= CHAR-CODE #\SP)
     302         (SETF (FONT-CHAR-WIDTH FONT) CW)))
     303  ;; Update the font's left-kern table, creating one if necessary.
     304  (LET ((CK (CD-CHAR-LEFT-KERN CD))
     305        (FCKT (FONT-LEFT-KERN-TABLE FONT)))
     306    (COND (FCKT (ASET CK FCKT CHAR-CODE))
     307          ((NOT (ZEROP CK))
     308           (SETF (FONT-LEFT-KERN-TABLE FONT)    ;MUST BE ART-32B BECAUSE LEFT-KERN
     309                 (SETQ FCKT (MAKE-ARRAY FONT-LENGTH ':TYPE ART-32B)))   ;CAN BE NEGATIVE
     310           (AND DOUBLE-WIDTH-P
     311                (SETF (FONT-LEFT-KERN-TABLE (FONT-NEXT-PLANE FONT))
     312                      FCKT))
     313           (ASET CK FCKT CHAR-CODE))))
     314  ;; Tell the font this char exists.
     315  (ERRSET (ASET 1 (FONT-CHARS-EXIST-TABLE FONT) CHAR-CODE) NIL)
     316  ;; In wide fonts, the raster width depends on the character, and is a multiple of 32.
     317  (COND ((FONT-INDEXING-TABLE FONT)
     318         (SETQ FONT-WIDTH (* (// (+ (ARRAY-DIMENSION-N 2 CD) 31.) 32.) 32.))))
     319  ;; Now copy the data.
     320  (DO ((ROW 0 (1+ ROW))
     321       (ONE-BIT-FONT (NULL (FONT-NEXT-PLANE FONT)))
     322       (RASTER-WIDTH (FONT-RASTER-WIDTH FONT)))
     323      ((
     324 ROW FONT-HEIGHT))
     325    (DO (
     326         ;; Count columns in font descriptor.
     327         (COL 0 (+ COL COL-INCR))
     328         ;; Count columns in font.
     329         (PIXEL-COL 0 (1+ PIXEL-COL))
     330         ;; for one-bit fonts this is index in font itself of start of row.
     331         ;; For multi-bit fonts it is not used.
     332         (NEXT-BIT-FONT-INDEX
     333           (+ (* 32. (+ (* (FONT-WORDS-PER-CHAR FONT)
     334                           (IF (FONT-INDEXING-TABLE FONT)
     335                               (AREF (FONT-INDEXING-TABLE FONT) CHAR-CODE)
     336                               CHAR-CODE))
     337                        (// ROW (FONT-RASTERS-PER-WORD FONT))))
     338              (* (FONT-RASTER-WIDTH FONT)
     339                 (\ ROW (FONT-RASTERS-PER-WORD FONT))))
     340           (1+ NEXT-BIT-FONT-INDEX)))
    269341        ((
    270  ROW FONT-HEIGHT))
    271         (DO ((COL 0 (+ COL COL-INCR))
    272              (PIXEL-COL 0 (1+ PIXEL-COL)))
    273             ((
    274342 PIXEL-COL FONT-WIDTH))
    275             (SETQ PIXEL (COND ((OR (>= COL WIDTH) (>= ROW HEIGHT)) 0)
    276                               (DOUBLE-WIDTH-P
    277                                (+ (COND ((>= (1+ COL) WIDTH) 0)
    278                                         (T (AR-2 CD ROW (1+ COL))))
    279                                   (* 2 (AR-2 CD ROW COL))))
    280                               (T (AR-2 CD ROW COL))))
    281             (FONT-SET-PIXEL PIXEL FONT CHAR-CODE
    282                             ROW PIXEL-COL))))
     343      ;; Get pixel out of font descriptor.
     344      ;; If font is "double width", two pixels of font descriptor
     345      ;; are combined into one pixel for the font itself.
     346      (SETQ PIXEL (COND ((OR (
     347 COL WIDTH) (
     348 ROW HEIGHT)) 0)
     349                        (DOUBLE-WIDTH-P
     350                         (+ (COND ((
     351 (1+ COL) WIDTH) 0)
     352                                  (T (AREF CD ROW (1+ COL))))
     353                            (* 2 (AREF CD ROW COL))))
     354                        (T (AREF CD ROW COL))))
     355      ;; Store pixel into font.
     356      ;; If pixels are only one bit and chars not too wide, use a short cut.
     357      (COND (ONE-BIT-FONT
     358             ;; In wide font, notice when our horizontal advance
     359             ;; carries us into the "next character" of the many characters
     360             ;; in the font which actually represent vertical strips of one character.
     361             (AND (ZEROP (\ PIXEL-COL RASTER-WIDTH))
     362                  (NOT (ZEROP PIXEL-COL))
     363                  (SETQ NEXT-BIT-FONT-INDEX
     364                        (- (+ NEXT-BIT-FONT-INDEX
     365                              (* 32. (FONT-WORDS-PER-CHAR FONT)))
     366                           RASTER-WIDTH)))
     367             (ASET PIXEL FONT NEXT-BIT-FONT-INDEX))
     368            (T
     369             (FONT-SET-PIXEL PIXEL FONT CHAR-CODE
     370                             ROW PIXEL-COL))))))
    283371
    284372
     
    286374
    287375(DEFUN FONT-INTO-FONT-DESCRIPTOR (FONT &OPTIONAL (DBL-WIDTH-P NIL)
    288                    &AUX (FONT-DESCRIPTOR (MAKE-FONT-DESCRIPTOR))
    289                         (LINE-SPACING (FONT-CHAR-HEIGHT FONT))
    290                         (RASTER-HEIGHT (FONT-RASTER-HEIGHT FONT))
    291                         (BASELINE (FONT-BASELINE FONT))
    292                         (BLINKER-HEIGHT (FONT-BLINKER-HEIGHT FONT))
    293                         (BLINKER-WIDTH (FONT-BLINKER-WIDTH FONT))
    294                         (SPACE-WIDTH (FONT-CHAR-WIDTH FONT))
    295                         FONT-CHARS-EXIST-TABLE
    296                         TEMP RASTER-WIDTH CHARACTER-WIDTH LEFT-KERN PIXEL
    297                         )
    298        (ERRSET (SETQ FONT-CHARS-EXIST-TABLE (FONT-CHARS-EXIST-TABLE FONT)) NIL)
    299        (SETF (FD-NAME FONT-DESCRIPTOR) (FONT-NAME FONT))
    300        (SETF (FD-LINE-SPACING FONT-DESCRIPTOR) LINE-SPACING)
    301        (SETF (FD-BASELINE FONT-DESCRIPTOR)BASELINE)
    302        (SETF (FD-BLINKER-HEIGHT FONT-DESCRIPTOR) BLINKER-HEIGHT)
    303        (SETF (FD-BLINKER-WIDTH FONT-DESCRIPTOR) BLINKER-WIDTH)
    304        (SETF (FD-SPACE-WIDTH FONT-DESCRIPTOR) SPACE-WIDTH)
    305        (SETF (FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR) DBL-WIDTH-P)
    306        (DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
    307            ((
    308  CHAR-CODE 200))
    309            (AND FONT-CHARS-EXIST-TABLE
    310                 (ZEROP (AR-1 FONT-CHARS-EXIST-TABLE CHAR-CODE))
    311                 (GO SKIP-CHAR))
    312            (SETQ CHARACTER-WIDTH (COND ((SETQ TEMP (FONT-CHAR-WIDTH-TABLE FONT))
    313                                         (AR-1 TEMP CHAR-CODE))
    314                                        (T (FONT-CHAR-WIDTH FONT))))
    315            (SETQ RASTER-WIDTH
    316                  (FONT-CHAR-MIN-RASTER-WIDTH FONT CHAR-CODE))
    317            (SETQ LEFT-KERN (COND ((SETQ TEMP (FONT-LEFT-KERN-TABLE FONT))
    318                                   (AR-1 TEMP CHAR-CODE))
    319                                  (T 0)))
    320            (SETQ TEMP (MAKE-CHAR-DESCRIPTOR
    321                                MAKE-ARRAY (NIL 'ART-4B (LIST RASTER-HEIGHT RASTER-WIDTH))
    322                                CD-CHAR-WIDTH CHARACTER-WIDTH
    323                                CD-CHAR-LEFT-KERN LEFT-KERN))
    324            (AS-1 TEMP FONT-DESCRIPTOR CHAR-CODE)
    325            (COND (DBL-WIDTH-P (DO ((ROW 0 (1+ ROW)))
    326                                   ((
     376       &AUX FONT-DESCRIPTOR
     377            (FONT-LENGTH (FONT-FILL-POINTER FONT))
     378            (LINE-SPACING (FONT-CHAR-HEIGHT FONT))
     379            (RASTER-HEIGHT (FONT-RASTER-HEIGHT FONT))
     380            (BASELINE (FONT-BASELINE FONT))
     381            (BLINKER-HEIGHT (FONT-BLINKER-HEIGHT FONT))
     382            (BLINKER-WIDTH (FONT-BLINKER-WIDTH FONT))
     383            (SPACE-WIDTH (FONT-CHAR-WIDTH FONT))
     384            FONT-CHARS-EXIST-TABLE
     385            TEMP RASTER-WIDTH CHARACTER-WIDTH LEFT-KERN PIXEL
     386            )
     387  (ERRSET (SETQ FONT-CHARS-EXIST-TABLE (FONT-CHARS-EXIST-TABLE FONT)) NIL)
     388  ;; Correct for old fonts that may not have valid fill pointers.
     389  (OR (AND FONT-LENGTH (
     390 FONT-LENGTH 200))
     391      (SETQ FONT-LENGTH 200))
     392  (SETQ FONT-DESCRIPTOR (MAKE-FONT-DESCRIPTOR MAKE-ARRAY (:LENGTH FONT-LENGTH)
     393                                              FD-FILL-POINTER FONT-LENGTH))
     394  (SETF (FD-NAME FONT-DESCRIPTOR) (FONT-NAME FONT))
     395  (SETF (FD-LINE-SPACING FONT-DESCRIPTOR) LINE-SPACING)
     396  (SETF (FD-BASELINE FONT-DESCRIPTOR)BASELINE)
     397  (SETF (FD-BLINKER-HEIGHT FONT-DESCRIPTOR) BLINKER-HEIGHT)
     398  (SETF (FD-BLINKER-WIDTH FONT-DESCRIPTOR) BLINKER-WIDTH)
     399  (SETF (FD-SPACE-WIDTH FONT-DESCRIPTOR) SPACE-WIDTH)
     400  (SETF (FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR) DBL-WIDTH-P)
     401  (DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
     402      ((
     403 CHAR-CODE FONT-LENGTH))
     404    (AND FONT-CHARS-EXIST-TABLE
     405         (ZEROP (AREF FONT-CHARS-EXIST-TABLE CHAR-CODE))
     406         (GO SKIP-CHAR))
     407    (SETQ CHARACTER-WIDTH (COND ((SETQ TEMP (FONT-CHAR-WIDTH-TABLE FONT))
     408                                 (AREF TEMP CHAR-CODE))
     409                                (T (FONT-CHAR-WIDTH FONT))))
     410    (SETQ RASTER-WIDTH
     411          (FONT-CHAR-MIN-RASTER-WIDTH FONT CHAR-CODE))
     412    ;; If we don't know for sure which chars exist,
     413    ;; discard chars containing no information.
     414    (AND (NULL FONT-CHARS-EXIST-TABLE)
     415         (ZEROP RASTER-WIDTH)
     416         ( CHAR-CODE #\SPACE)
     417         (= CHARACTER-WIDTH (FONT-CHAR-WIDTH FONT))
     418         (GO SKIP-CHAR))
     419    (SETQ LEFT-KERN (COND ((SETQ TEMP (FONT-LEFT-KERN-TABLE FONT))
     420                           (AREF TEMP CHAR-CODE))
     421                          (T 0)))
     422    (SETQ TEMP (MAKE-CHAR-DESCRIPTOR
     423                 MAKE-ARRAY (:TYPE 'ART-4B
     424                                   :LENGTH (LIST RASTER-HEIGHT RASTER-WIDTH))
     425                 CD-CHAR-WIDTH CHARACTER-WIDTH
     426                 CD-CHAR-LEFT-KERN LEFT-KERN))
     427    (ASET TEMP FONT-DESCRIPTOR CHAR-CODE)
     428    (COND (DBL-WIDTH-P (DO ((ROW 0 (1+ ROW)))
     429                           ((
    327430 ROW RASTER-HEIGHT))
    328                                   (DO ((COLI 0 (1+ COLI))
    329                                        (COL 0 (+ 2 COL)))
    330                                       ((
     431                        (DO ((COLI 0 (1+ COLI))
     432                              (COL 0 (+ 2 COL)))
     433                             ((
    331434 COL RASTER-WIDTH))
    332                                       (SETQ PIXEL (FONT-GET-PIXEL FONT CHAR-CODE ROW COLI))
    333                                       (AS-2 PIXEL TEMP ROW COL)
    334                                       (AS-2 (LSH PIXEL -1) TEMP ROW (1+ COL)))))
    335                  (T (DO ((ROW 0 (1+ ROW)))
    336                         ((
     435                           (SETQ PIXEL (FONT-GET-PIXEL FONT CHAR-CODE ROW COLI))
     436                           (ASET PIXEL TEMP ROW COL)
     437                           (ASET (LSH PIXEL -1) TEMP ROW (1+ COL)))))
     438          (T (DO ((ROW 0 (1+ ROW)))
     439                ((
    337440 ROW RASTER-HEIGHT))
    338                         (DO ((COL 0 (1+ COL)))
    339                             ((
     441               (DO ((COL 0 (1+ COL)))
     442                   ((
    340443 COL RASTER-WIDTH))
    341                             (AS-2 (FONT-GET-PIXEL FONT CHAR-CODE ROW COL)
    342                                   TEMP ROW COL)))))
    343            SKIP-CHAR)
    344        FONT-DESCRIPTOR)
    345 
     444                 (ASET (FONT-GET-PIXEL FONT CHAR-CODE ROW COL)
     445                       TEMP ROW COL)))))
     446    SKIP-CHAR)
     447  FONT-DESCRIPTOR)
     448
     449
     450;; Given filename and fontname from filename &optional fontname, canonicalize them
     451(DEFUN GET-INPUT-FILENAME-AND-FONTNAME (FILENAME FONTNAME FILE-TYPE)
     452  (DECLARE (RETURN-LIST FILENAME FONTNAME))
     453  (SETQ FILENAME (FS:MERGE-PATHNAME-DEFAULTS FILENAME (PATHNAME-DEFAULTS) FILE-TYPE))
     454  (OR FONTNAME (SETQ FONTNAME (FUNCALL FILENAME ':NAME)))
     455  (AND (STRINGP FONTNAME) (SETQ FONTNAME (INTERN (STRING-UPCASE FONTNAME) "FONTS")))
     456  (VALUES FILENAME FONTNAME))
    346457
    347458;; Read in a kst file and make and return a FONT-DESCRIPTOR,
    348459;; which is an alternate convenient representation for a font.
    349 (defun read-kst-into-font-descriptor (filename &optional fontname &aux stream fd)
    350   (setq filename (fs:file-parse-name filename nil t ':kst))
    351   (or fontname (setq fontname (funcall filename ':name)))
    352   (and (stringp fontname) (setq fontname (intern fontname "FONTS")))
    353   (setq stream (open filename '(:fixnum :in :byte-size 9.)))
    354   (setq fd (make-font-descriptor fd-name fontname))
    355   ;; Discard KSTID.
    356   (dotimes (i 4) (funcall stream ':tyi))
    357   ;; Discard column position adjust until I find out what it means.
    358   (or (zerop (funcall stream ':tyi))
    359       (ferror nil
    360               "Nonzero column-position-adjust in font ~A -- what does that mean?"
    361               fontname))
    362   (setf (fd-space-width fd) 0)                  ;Just in case no space character.
    363   (setf (fd-baseline fd) (funcall stream ':tyi))
    364   (setf (fd-line-spacing fd) (read-kst-halfword stream))
    365   (setf (fd-blinker-height fd)
    366         (fd-line-spacing fd))
    367   (setf (fd-name fd) fontname)
    368   (let (kern char-code raster-width char-width byte-list byte-list-head cd tem
    369              (line-height (fd-line-spacing fd)))
    370     (do () ((= (logand (read-kst-halfword stream) (read-kst-halfword stream)) -1))
    371       (setq kern (read-kst-halfword stream))
    372       (setq char-code (read-kst-halfword stream))
    373       (setq raster-width (read-kst-halfword stream))
    374       (setq char-width (read-kst-halfword stream))
    375       (setq cd (make-char-descriptor
    376                  make-array (nil art-1b (list line-height raster-width))))
    377       (setf (cd-char-width cd) char-width)
    378       (setf (cd-char-left-kern cd) kern)
    379       (as-1 cd fd char-code)
    380       (and (= char-code #/ )
    381            (setf (fd-space-width fd) char-width))
    382       ;; read in the bits of the character
    383       (setq byte-list nil
    384             byte-list-head (list nil nil nil nil))
    385       (dotimes (vpos line-height)
    386         ;; Read in the next row.
    387         (dotimes (hpos raster-width)
    388           ;; If byte is exhausted, get next byte into (car byte-list)
    389           (cond ((zerop (\ hpos 8))
    390                  (setq byte-list (read-kst-bytes stream byte-list byte-list-head))))
    391           (setq tem (logand 1 (lsh (car byte-list) (- (\ hpos 8)))))
    392           (as-2 tem cd vpos hpos)))))
    393   (setf (fd-fill-pointer fd) 200)
    394   ;; Set width of blinker and space fields from the space character.
    395   (setf (fd-blinker-width fd)
    396         (fd-space-width fd))
    397   (funcall stream ':close)
    398   fd)
     460(DEFUN READ-KST-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME &AUX FD)
     461  (MULTIPLE-VALUE (FILENAME FONTNAME)
     462    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "KST"))
     463  (WITH-OPEN-FILE (STREAM FILENAME '(:FIXNUM :IN :BYTE-SIZE 9.))
     464    (SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME MAKE-ARRAY (:LENGTH 200)))
     465    ;; Discard KSTID.
     466    (DOTIMES (I 4) (FUNCALL STREAM ':TYI))
     467    ;; Discard column position adjust until I find out what it means.
     468    (OR (ZEROP (FUNCALL STREAM ':TYI))
     469        (FERROR NIL
     470                "Nonzero column-position-adjust in font ~A -- what does that mean?"
     471                FONTNAME))
     472    (SETF (FD-SPACE-WIDTH FD) 0)                ;Just in case no space character.
     473    (SETF (FD-BASELINE FD) (FUNCALL STREAM ':TYI))
     474    (SETF (FD-LINE-SPACING FD) (READ-KST-HALFWORD STREAM))
     475    (SETF (FD-BLINKER-HEIGHT FD)
     476          (FD-LINE-SPACING FD))
     477    (SETF (FD-NAME FD) FONTNAME)
     478    (LET (KERN CHAR-CODE RASTER-WIDTH CHAR-WIDTH BYTE-LIST BYTE-LIST-HEAD CD TEM
     479          (LINE-HEIGHT (FD-LINE-SPACING FD)))
     480      (LOOP AS HEADER = (LOGIOR (ASH (READ-KST-HALFWORD STREAM) 18.)
     481                                (READ-KST-HALFWORD STREAM))
     482            UNTIL (= HEADER -1)
     483            UNLESS (= HEADER 1)
     484              DO (FERROR NIL "~O where character header expected; KST file misformatted"
     485                             HEADER)
     486        DO
     487        (SETQ KERN (READ-KST-HALFWORD STREAM))
     488        (SETQ CHAR-CODE (READ-KST-HALFWORD STREAM))
     489        (SETQ RASTER-WIDTH (READ-KST-HALFWORD STREAM))
     490        (SETQ CHAR-WIDTH (READ-KST-HALFWORD STREAM))
     491        (SETQ CD (MAKE-CHAR-DESCRIPTOR
     492                   MAKE-ARRAY (:TYPE ART-1B :LENGTH (LIST LINE-HEIGHT RASTER-WIDTH))))
     493        (SETF (CD-CHAR-WIDTH CD) CHAR-WIDTH)
     494        (SETF (CD-CHAR-LEFT-KERN CD) KERN)
     495        (FD-STORE-CD FD CD CHAR-CODE)
     496        (AND (= CHAR-CODE #\SP)
     497             (SETF (FD-SPACE-WIDTH FD) CHAR-WIDTH))
     498        ;; read in the bits of the character
     499        (SETQ BYTE-LIST NIL
     500              BYTE-LIST-HEAD (LIST NIL NIL NIL NIL))
     501        (DOTIMES (VPOS LINE-HEIGHT)
     502          ;; Read in the next row.
     503          (DOTIMES (HPOS RASTER-WIDTH)
     504            ;; If byte is exhausted, get next byte into (car byte-list)
     505            (COND ((ZEROP (\ HPOS 8))
     506                   (SETQ BYTE-LIST (READ-KST-BYTES STREAM BYTE-LIST BYTE-LIST-HEAD))))
     507            (SETQ TEM (LOGAND 1 (LSH (CAR BYTE-LIST) (- (\ HPOS 8)))))
     508            (ASET TEM CD VPOS HPOS)))))
     509    ;; Truncate fd to discard unused elements at the end.
     510    (DO ((I (1- (ARRAY-LENGTH FD)) (1- I)))
     511        ((OR (MINUSP I)
     512             (AREF FD I))
     513         (ADJUST-ARRAY-SIZE FD (1+ I))))
     514    (SETF (FD-FILL-POINTER FD) (ARRAY-LENGTH FD))
     515    ;; Set width of blinker and space fields from the space character.
     516    (SETF (FD-BLINKER-WIDTH FD)
     517          (FD-SPACE-WIDTH FD)))
     518  FD)
    399519
    400520
    401521;; Read in a kst file and define a font.
    402522;; The font name defaults from the file name.
    403 (defun read-kst-into-font (filename &optional fontname
    404                                     &aux stream font chars-exist-table
    405                                     raster-width raster-height
    406                                     rasters-per-word words-per-char)
    407     (setq filename (fs:file-parse-name filename nil t ':kst))
    408     (or fontname (setq fontname (funcall filename ':name)))
    409     (and (stringp fontname) (setq fontname (intern fontname "FONTS")))
    410     ;; Read file once to determine font parameters.
    411     (multiple-value (raster-width raster-height)
    412                     (read-kst-max-raster-width filename))
    413     ;; If this is a hairy wide font, then instead of writing it directly
    414     ;; make a font-descriptor and turn it into a font.
    415     (cond ((> raster-width 32.)
    416            (font-name-set-font-and-descriptor
    417                fontname
    418                (read-kst-into-font-descriptor filename fontname))
    419            fontname)
    420           (t
    421            (setq rasters-per-word (// 32. raster-width))
    422            (setq words-per-char (// (+ raster-height rasters-per-word -1) rasters-per-word))
    423            ;; Now that we know the parameters, allocate the font.
    424            (setq font (tv:make-font make-array (nil art-1b (* words-per-char 32. 200))))
    425            (setf (font-rasters-per-word font) rasters-per-word)
    426            (setf (font-words-per-char font) words-per-char)
    427            (setf (font-raster-width font) raster-width)
    428            (setf (font-raster-height font) raster-height)
    429            (setf (font-char-height font) raster-height)
    430            (setf (font-blinker-height font) raster-height)
    431            (setf (font-name font) fontname)
    432            (setq chars-exist-table (make-array nil art-1b 200))
    433            (setf (font-chars-exist-table font) chars-exist-table)
    434            ;; Now actually read in the data of the font.
    435            (setq stream (open filename '(:fixnum :in :byte-size 9.)))
     523;;;??? This still assumes that the font length is no more than 200!
     524;;; It seems hard to fix this.
     525(DEFUN READ-KST-INTO-FONT (FILENAME &OPTIONAL FONTNAME
     526                                    &AUX FONT CHARS-EXIST-TABLE
     527                                         RASTER-WIDTH RASTER-HEIGHT
     528                                         RASTERS-PER-WORD WORDS-PER-CHAR)
     529  (MULTIPLE-VALUE (FILENAME FONTNAME)
     530    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "KST"))
     531  ;; Read file once to determine font parameters.
     532  (MULTIPLE-VALUE (RASTER-WIDTH RASTER-HEIGHT)
     533    (READ-KST-MAX-RASTER-WIDTH FILENAME))
     534  ;; If this is a hairy wide font, then instead of writing it directly
     535  ;; make a font-descriptor and turn it into a font.
     536  (COND ((> RASTER-WIDTH 32.)
     537         (FONT-NAME-SET-FONT-AND-DESCRIPTOR
     538           FONTNAME
     539           (READ-KST-INTO-FONT-DESCRIPTOR FILENAME FONTNAME))
     540         FONTNAME)
     541        (T
     542         (SETQ RASTERS-PER-WORD (// 32. RASTER-WIDTH))
     543         (SETQ WORDS-PER-CHAR (// (+ RASTER-HEIGHT RASTERS-PER-WORD -1) RASTERS-PER-WORD))
     544         ;; Now that we know the parameters, allocate the font.
     545         (SETQ FONT (TV:MAKE-FONT MAKE-ARRAY (:TYPE 'ART-1B
     546                                                    :LENGTH (* WORDS-PER-CHAR 32. 200))))
     547         (SETF (FONT-RASTERS-PER-WORD FONT) RASTERS-PER-WORD)
     548         (SETF (FONT-WORDS-PER-CHAR FONT) WORDS-PER-CHAR)
     549         (SETF (FONT-RASTER-WIDTH FONT) RASTER-WIDTH)
     550         (SETF (FONT-RASTER-HEIGHT FONT) RASTER-HEIGHT)
     551         (SETF (FONT-CHAR-HEIGHT FONT) RASTER-HEIGHT)
     552         (SETF (FONT-BLINKER-HEIGHT FONT) RASTER-HEIGHT)
     553         (SETF (FONT-NAME FONT) FONTNAME)
     554         (SETQ CHARS-EXIST-TABLE (MAKE-ARRAY 200 ':TYPE 'ART-1B))
     555         (SETF (FONT-CHARS-EXIST-TABLE FONT) CHARS-EXIST-TABLE)
     556         ;; Now actually read in the data of the font.
     557         (WITH-OPEN-FILE (STREAM FILENAME '(:FIXNUM :IN :BYTE-SIZE 9.))
    436558           ;; Discard KSTID.
    437            (dotimes (i 4) (funcall stream ':tyi))
     559           (DOTIMES (I 4) (FUNCALL STREAM ':TYI))
    438560           ;; Discard column position adjust until I find out what it means.
    439            (or (zerop (funcall stream ':tyi))
    440                (ferror nil
     561           (OR (ZEROP (FUNCALL STREAM ':TYI))
     562               (FERROR NIL
    441563                       "Nonzero column-position-adjust in font ~A -- what does that mean?"
    442                        fontname))
    443            (setf (font-baseline font) (funcall stream ':tyi))
     564                       FONTNAME))
     565           (SETF (FONT-BASELINE FONT) (FUNCALL STREAM ':TYI))
    444566           ;; Discard line height (already determined).
    445            (read-kst-halfword stream)
    446            (let (kern char-code char-width char-raster-width
    447                       byte-list byte-list-head tem bit-pos word-pos
    448                       (line-height raster-height))
    449                (do () ((= (logand (read-kst-halfword stream) (read-kst-halfword stream)) -1))
    450                    (setq kern (read-kst-halfword stream))
    451                    (setq char-code (read-kst-halfword stream))
    452                    ;; While all chars have the same raster width in the lisp machine font,
    453                    ;; we need the raster width stored in the kst file to read the kst file.
    454                    (setq char-raster-width (read-kst-halfword stream))
    455                    (setq char-width (read-kst-halfword stream))
    456                    (as-1 1 chars-exist-table char-code)
    457                    ;; Now store the char width and left kern, creating the tables if nec.
    458                    (cond ((null (font-char-width font))
    459                           (setf (font-char-width font) char-width))
    460                          ((font-char-width-table font)
    461                           (as-1 char-width (font-char-width-table font) char-code))
    462                          ((= char-width (font-char-width font)))
    463                          (t (setf (font-char-width-table font)
    464                                   (make-array nil art-16b 200))
    465                             (as-1 char-width (font-char-width-table font) char-code)))
    466                    (and (= char-code #/ )
    467                         (setf (font-char-width font) char-width))
    468                    (cond ((not (zerop kern))
    469                           (or (font-left-kern-table font)
    470                               (setf (font-left-kern-table font)
    471                                     ;; Use art-32b so can hold both signs.
    472                                     (make-array nil art-32b 200)))
    473                           (as-1 kern (font-left-kern-table font) char-code)))
    474                    ;; read in the bits of the character
    475                    (setq byte-list nil
    476                          byte-list-head (list nil nil nil nil))
    477                    (setq word-pos (* char-code words-per-char)
    478                          bit-pos 0)
    479                    (dotimes (vpos line-height)
    480                       ;; Find next row in font - advance to word boundary if nec.
    481                       (and (> (+ bit-pos raster-width) 32.)
    482                            (setq bit-pos 0 word-pos (1+ word-pos)))
    483                       ;; Read in that row.
    484                       (dotimes (hpos char-raster-width)
    485                          ;; If byte is exhausted, get next byte into (car byte-list)
    486                          (cond ((zerop (\ hpos 8))
    487                                 (setq byte-list (read-kst-bytes stream byte-list byte-list-head))))
    488                          (setq tem (logand 1 (lsh (car byte-list) (- (\ hpos 8)))))
    489                          (as-1 tem font (+ (lsh word-pos 5) bit-pos hpos)))
    490                       ;; Advance past this row in the font.
    491                       (setq bit-pos (+ bit-pos raster-width)))
    492                    ))
    493            ;; Set width of blinker and space fields from the space character.
    494            (setf (font-blinker-width font)
    495                  (font-char-width font))
    496            (set fontname font)
    497            (putprop fontname filename 'kst-file)
    498            (funcall stream ':close)
    499            fontname)))
     567           (READ-KST-HALFWORD STREAM)
     568           (LET (KERN CHAR-CODE CHAR-WIDTH CHAR-RASTER-WIDTH
     569                 BYTE-LIST BYTE-LIST-HEAD TEM BIT-POS WORD-POS
     570                 (LINE-HEIGHT RASTER-HEIGHT))
     571             (LOOP AS HEADER = (LOGIOR (ASH (READ-KST-HALFWORD STREAM) 18.)
     572                                       (READ-KST-HALFWORD STREAM))
     573                   UNTIL (= HEADER -1)
     574                   UNLESS (= HEADER 1)
     575                     DO (FERROR NIL
     576                                "~O where character header expected; KST file misformatted"
     577                                HEADER)
     578               DO
     579               (SETQ KERN (READ-KST-HALFWORD STREAM))
     580               (SETQ CHAR-CODE (READ-KST-HALFWORD STREAM))
     581               ;; While all chars have the same raster width in the lisp machine font,
     582               ;; we need the raster width stored in the kst file to read the kst file.
     583               (SETQ CHAR-RASTER-WIDTH (READ-KST-HALFWORD STREAM))
     584               (SETQ CHAR-WIDTH (READ-KST-HALFWORD STREAM))
     585               (ASET 1 CHARS-EXIST-TABLE CHAR-CODE)
     586               ;; Now store the char width and left kern, creating the tables if nec.
     587               (COND ((NULL (FONT-CHAR-WIDTH FONT))
     588                      (SETF (FONT-CHAR-WIDTH FONT) CHAR-WIDTH))
     589                     ((FONT-CHAR-WIDTH-TABLE FONT)
     590                      (ASET CHAR-WIDTH (FONT-CHAR-WIDTH-TABLE FONT) CHAR-CODE))
     591                     ((= CHAR-WIDTH (FONT-CHAR-WIDTH FONT)))
     592                     (T (SETF (FONT-CHAR-WIDTH-TABLE FONT)
     593                              (MAKE-ARRAY 200 ':TYPE 'ART-16B))
     594                        (ASET CHAR-WIDTH (FONT-CHAR-WIDTH-TABLE FONT) CHAR-CODE)))
     595               (AND (= CHAR-CODE #\SP)
     596                    (SETF (FONT-CHAR-WIDTH FONT) CHAR-WIDTH))
     597               (COND ((NOT (ZEROP KERN))
     598                      (OR (FONT-LEFT-KERN-TABLE FONT)
     599                          (SETF (FONT-LEFT-KERN-TABLE FONT)
     600                                ;; Use art-32b so can hold both signs.
     601                                (MAKE-ARRAY 200 ':TYPE 'ART-32B)))
     602                      (ASET KERN (FONT-LEFT-KERN-TABLE FONT) CHAR-CODE)))
     603               ;; read in the bits of the character
     604               (SETQ BYTE-LIST NIL
     605                     BYTE-LIST-HEAD (LIST NIL NIL NIL NIL))
     606               (SETQ WORD-POS (* CHAR-CODE WORDS-PER-CHAR)
     607                     BIT-POS 0)
     608               (DOTIMES (VPOS LINE-HEIGHT)
     609                 ;; Find next row in font - advance to word boundary if nec.
     610                 (AND (> (+ BIT-POS RASTER-WIDTH) 32.)
     611                      (SETQ BIT-POS 0 WORD-POS (1+ WORD-POS)))
     612                 ;; Read in that row.
     613                 (DOTIMES (HPOS CHAR-RASTER-WIDTH)
     614                   ;; If byte is exhausted, get next byte into (car byte-list)
     615                   (COND ((ZEROP (\ HPOS 8))
     616                          (SETQ BYTE-LIST (READ-KST-BYTES STREAM BYTE-LIST
     617                                                          BYTE-LIST-HEAD))))
     618                   (SETQ TEM (LOGAND 1 (LSH (CAR BYTE-LIST) (- (\ HPOS 8)))))
     619                   (ASET TEM FONT (+ (LSH WORD-POS 5) BIT-POS HPOS)))
     620                 ;; Advance past this row in the font.
     621                 (SETQ BIT-POS (+ BIT-POS RASTER-WIDTH)))
     622               )))
     623         ;; Set width of blinker and space fields from the space character.
     624         (SETF (FONT-BLINKER-WIDTH FONT)
     625               (FONT-CHAR-WIDTH FONT))
     626         (SET FONTNAME FONT)
     627         (PUTPROP FONTNAME FILENAME 'KST-FILE)
     628         FONTNAME)))
    500629
    501630
    502631;; Scan a kst file and return two values which are the
    503632;; raster width and raster height needed in a TV format font to contain that font.
    504 (defun read-kst-max-raster-width (filename &aux stream
    505                                                 raster-height (raster-width 0)
    506                                                 char-raster-width)
    507   (setq stream (open (fs:file-parse-name filename nil t ':kst) '(:fixnum :in :byte-size 9.)))
    508   ;; Discard KSTID.
    509   (dotimes (i 4) (funcall stream ':tyi))
    510   ;; Discard column-position-adjust
    511   (funcall stream ':tyi)
    512   ;; Discard baseline.
    513   (funcall stream ':tyi)
    514   ;; Remember font line height as raster height.
    515   (setq raster-height (read-kst-halfword stream))
    516   ;; Keep maxing raster widths of characters into raster-width
    517   (setq raster-width 0)
    518   (do () ((= (logand (read-kst-halfword stream) (read-kst-halfword stream)) -1))
    519     ;; Ignore char's left kern.
    520     (read-kst-halfword stream)
    521     ;; Ignore its character code.
    522     (read-kst-halfword stream)
    523     ;; Max in its raster width
    524     (setq char-raster-width (read-kst-halfword stream))
    525     (setq raster-width (max raster-width char-raster-width))
    526     ;; Ignore its character width.
    527     (read-kst-halfword stream)
    528     ;; Skip the bits of the character
    529     (prog ((bytes (* raster-height (// (+ char-raster-width 7) 8))))
    530           (setq bytes (* 4 (// (+ bytes 3) 4)))
    531           (dotimes (i bytes)
    532             (funcall stream ':tyi))))
    533   (funcall stream ':close)
    534   (prog () (return raster-width raster-height)))
     633(DEFUN READ-KST-MAX-RASTER-WIDTH (FILENAME &AUX RASTER-HEIGHT (RASTER-WIDTH 0)
     634                                                CHAR-RASTER-WIDTH)
     635  (SETQ FILENAME (FS:MERGE-PATHNAME-DEFAULTS FILENAME (PATHNAME-DEFAULTS) "KST"))
     636  (WITH-OPEN-FILE (STREAM FILENAME '(:FIXNUM :IN :BYTE-SIZE 9.))
     637    ;; Discard KSTID.
     638    (DOTIMES (I 4) (FUNCALL STREAM ':TYI))
     639    ;; Discard column-position-adjust
     640    (FUNCALL STREAM ':TYI)
     641    ;; Discard baseline.
     642    (FUNCALL STREAM ':TYI)
     643    ;; Remember font line height as raster height.
     644    (SETQ RASTER-HEIGHT (READ-KST-HALFWORD STREAM))
     645    ;; Keep maxing raster widths of characters into raster-width
     646    (SETQ RASTER-WIDTH 0)
     647    (LOOP AS HEADER = (LOGIOR (ASH (READ-KST-HALFWORD STREAM) 18.) (READ-KST-HALFWORD STREAM))
     648          UNTIL (= HEADER -1)
     649          UNLESS (= HEADER 1)
     650            DO (FERROR NIL "~O where character header expected; KST file misformatted" HEADER)
     651      DO
     652      ;; Ignore char's left kern.
     653      (READ-KST-HALFWORD STREAM)
     654      ;; Ignore its character code.
     655      (READ-KST-HALFWORD STREAM)
     656      ;; Max in its raster width
     657      (SETQ CHAR-RASTER-WIDTH (READ-KST-HALFWORD STREAM))
     658      (SETQ RASTER-WIDTH (MAX RASTER-WIDTH CHAR-RASTER-WIDTH))
     659      ;; Ignore its character width.
     660      (READ-KST-HALFWORD STREAM)
     661      ;; Skip the bits of the character
     662      (LET ((BYTES (* RASTER-HEIGHT (// (+ CHAR-RASTER-WIDTH 7) 8))))
     663        (SETQ BYTES (* 4 (// (+ BYTES 3) 4)))
     664        (DOTIMES (I BYTES)
     665          (FUNCALL STREAM ':TYI)))))
     666  (VALUES RASTER-WIDTH RASTER-HEIGHT))
    535667
    536668;; Fetch the next 8-bit byte where stream is a 9-bit byte stream.
     
    541673;; The car of our value is the next byte.
    542674;; Save the value for the byte-list arg next time.
    543 (defun read-kst-bytes (stream byte-list byte-list-head)
    544     (or (cdr byte-list)
    545         ;; Exhausted the word - read another.
    546         (let ((hwd1 (read-kst-halfword stream))
    547               (hwd2 (read-kst-halfword stream)))
    548              (setq byte-list byte-list-head)
    549              ;; Turn it into 4 8-bit bytes in byte-list.
    550              (rplaca byte-list (ldb 1210 hwd1))
    551              (rplaca (cdr byte-list) (ldb 0210 hwd1))
    552              (rplaca (cddr byte-list)
    553                      (+ (lsh (ldb 0002 hwd1) 6)
    554                         (ldb 1406 hwd2)))
    555              (rplaca (cdddr byte-list) (ldb 0410 hwd2))
    556              byte-list)))
     675(DEFUN READ-KST-BYTES (STREAM BYTE-LIST BYTE-LIST-HEAD)
     676  (OR (CDR BYTE-LIST)
     677      ;; Exhausted the word - read another.
     678      (LET ((HWD1 (READ-KST-HALFWORD STREAM))
     679            (HWD2 (READ-KST-HALFWORD STREAM)))
     680        (SETQ BYTE-LIST BYTE-LIST-HEAD)
     681        ;; Turn it into 4 8-bit bytes in byte-list.
     682        (RPLACA BYTE-LIST (LDB 1210 HWD1))
     683        (RPLACA (CDR BYTE-LIST) (LDB 0210 HWD1))
     684        (RPLACA (CDDR BYTE-LIST)
     685                (+ (LSH (LDB 0002 HWD1) 6)
     686                   (LDB 1406 HWD2)))
     687        (RPLACA (CDDDR BYTE-LIST) (LDB 0410 HWD2))
     688        BYTE-LIST)))
    557689
    558690;; Read two 9-bit bytes from stream, make an 18-bit halfword,
    559691;; and sign-extend it.
    560 (defun read-kst-halfword (stream &aux hwd)
    561     (setq hwd (+ (* (funcall stream ':tyi) 1000)
    562                  (funcall stream ':tyi)))
    563     (cond ((bit-test hwd 400000)
    564            (logior hwd -400000))
    565           (t hwd)))
    566 
     692(DEFUN READ-KST-HALFWORD (STREAM &AUX HWD)
     693  (SETQ HWD (+ (* (FUNCALL STREAM ':TYI) 1000)
     694               (FUNCALL STREAM ':TYI)))
     695  (COND ((BIT-TEST HWD 400000)
     696         (LOGIOR HWD -400000))
     697        (T HWD)))
     698
     699
     700;;; Given FONTNAME and FILENAME from FONTNAME &OPTIONAL FILENAME, canonicalize them.
     701(DEFUN GET-OUTPUT-FILENAME-AND-FONTNAME (FONTNAME FILENAME FILE-TYPE)
     702  (DECLARE (RETURN-LIST FONTNAME FILENAME))
     703  (AND (STRINGP FONTNAME) (SETQ FONTNAME (INTERN (STRING-UPCASE FONTNAME) "FONTS")))
     704  (OR FILENAME (SETQ FILENAME (STRING FONTNAME)))
     705  (SETQ FILENAME (FS:MERGE-PATHNAME-DEFAULTS FILENAME (PATHNAME-DEFAULTS) FILE-TYPE))
     706  (VALUES FONTNAME FILENAME))
     707
     708(DEFUN GET-OUTPUT-FILENAME-FROM-FONT-DESCRIPTOR (FONT-DESCRIPTOR FILENAME FILE-TYPE)
     709  (OR FILENAME (SETQ FILENAME (STRING (FD-NAME FONT-DESCRIPTOR))))
     710  (FS:MERGE-PATHNAME-DEFAULTS FILENAME (PATHNAME-DEFAULTS) FILE-TYPE))
    567711
    568712;; It would be good to check for chars that are all zero and
    569713;; flush them, and also to compute the actual needed raster width and use it.
    570 (defun write-font-into-kst (fontname &optional filename &aux stream font)
    571   (and (stringp fontname) (setq fontname (intern fontname "FONTS")))
    572   (setq filename (fs:file-parse-name filename nil t ':kst))
    573   (setq font (symeval fontname))
    574   (cond ((font-indexing-table font)
    575          (let ((fd (font-name-font-descriptor fontname)))
    576            (write-font-descriptor-into-kst fd filename)))
    577         (t
    578          (and (> (font-raster-height font)
    579                  (font-char-height font))
    580               (format t "Warning: font raster height exceeds line height"))
    581          (setq stream (open filename '(:fixnum :out :byte-size 9.)))
    582          ;; Write KSTID as 0.
    583          (dotimes (i 4) (funcall stream ':tyo 0))
    584          ;; Write column position adjust as 0.
    585          (funcall stream ':tyo 0)
    586          ;; Write baseline and height into second header word.
    587          (funcall stream ':tyo (font-baseline font))
    588          (write-kst-halfword stream (font-char-height font))
    589          ;; Then write out all the characters.
    590          (let (kern-table char-width-table chars-exist-table
    591                           word-pos bit-pos byte-count byte
    592                           char-raster-width byte-list byte-list-head)
    593            (setq kern-table (font-left-kern-table font)
    594                  char-width-table (font-char-width-table font))
    595            (errset (setq chars-exist-table (font-chars-exist-table font)) nil)
    596            (dotimes (char-code 200)
    597              (and chars-exist-table
    598                   (zerop (ar-1 chars-exist-table char-code))
    599                   (go skip-char))
    600              ;; Each char must start with a word containing a 1.
    601              (write-kst-halfword stream 0)
    602              (write-kst-halfword stream 1)
    603              ;; left kern and char code fill the next word.
    604              (write-kst-halfword stream
    605                                  (or (and kern-table (ar-1 kern-table char-code)) 0))
    606              (write-kst-halfword stream char-code)
    607              ;; Raster width and char width are the next word.
    608              (setq char-raster-width (max 1 (font-char-min-raster-width font char-code)))
    609              (write-kst-halfword stream char-raster-width)
    610              (write-kst-halfword stream
    611                                  (cond (char-width-table (or (ar-1 char-width-table char-code) 0))
    612                                        (t (font-char-width font))))
    613              ;; Write out the bits of the character
    614              ;; Word-pos and bit-pos are used to point at a bit in the font.
    615              (setq word-pos (* (font-words-per-char font) char-code))
    616              (setq bit-pos 0 byte-count 0)
    617              ;; Byte-list and its head are used to accumulate 4 bytes
    618              ;; and then output them at once as a word.
    619              ;; This is needed because the stream wants 9-bit bytes.
    620              (setq byte-list-head (list nil nil nil nil))
    621              (setq byte-list byte-list-head)
    622              (dotimes (vpos (font-char-height font))
    623                ;; Prepare to extract next row of char from font.
    624                (and (> (+ bit-pos (font-raster-width font)) 32.)
    625                     (setq word-pos (1+ word-pos) bit-pos 0))
    626                (setq byte 0)
    627                ;; Get the row a bit at a time and fill up 8-bit bytes.
    628                ;; Output the bytes when full.  Output the excess at the end.
    629                ;; Count the bytes output with byte-count
    630                (dotimes (hpos char-raster-width)
    631                  (cond ((and (= (\ hpos 8) 0) (not (zerop hpos)))
    632                         (setq byte-count (1+ byte-count))
    633                         (setq byte-list
    634                               (write-kst-byte stream byte byte-list byte-list-head))
    635                         (setq byte 0)))
    636                  (or (
    637  vpos (font-raster-height font))
    638                      (setq byte (+ byte (lsh (ar-1 font
    639                                                    (+ (* 32. word-pos) hpos bit-pos))
    640                                              (\ hpos 8))))))
    641                (setq byte-count (1+ byte-count))
    642                (setq byte-list (write-kst-byte stream byte byte-list byte-list-head))
    643                (setq bit-pos (+ bit-pos (font-raster-width font))))
    644              ;; Pad to a word boundary.
    645              (do () ((zerop (\ byte-count 4)))
    646                (setq byte-list (write-kst-byte stream 0 byte-list byte-list-head))
    647                (setq byte-count (1+ byte-count)))
    648              skip-char)
    649            ;; Mark end of file with two -1 words.
    650            (dotimes (i 8)
    651              (funcall stream ':tyo -1)))
    652          (close stream))))
    653 
    654 
    655 (defun write-font-descriptor-into-kst (fd filename &aux stream)
    656     (setq stream (open (fs:file-parse-name filename nil t ':kst)
    657                        '(:fixnum :out :byte-size 9.)))
     714(DEFUN WRITE-FONT-INTO-KST (FONTNAME &OPTIONAL FILENAME &AUX FONT FONT-LENGTH)
     715  (MULTIPLE-VALUE (FONTNAME FILENAME)
     716    (GET-OUTPUT-FILENAME-AND-FONTNAME FONTNAME FILENAME "KST"))
     717  (SETQ FONT (SYMEVAL FONTNAME))
     718  (SETQ FONT-LENGTH (FONT-FILL-POINTER FONT))
     719  (OR (AND FONT-LENGTH (
     720 FONT-LENGTH 200))
     721      (SETQ FONT-LENGTH 200))
     722  (COND ((FONT-INDEXING-TABLE FONT)
     723         (LET ((FD (FONT-NAME-FONT-DESCRIPTOR FONTNAME)))
     724           (WRITE-FONT-DESCRIPTOR-INTO-KST FD FILENAME)))
     725        (T
     726         (AND (> (FONT-RASTER-HEIGHT FONT)
     727                 (FONT-CHAR-HEIGHT FONT))
     728              (FORMAT T "Warning: font raster height exceeds line height"))
     729         (WITH-OPEN-FILE (STREAM FILENAME '(:FIXNUM :OUT :BYTE-SIZE 9.))
     730           ;; Write KSTID as 0.
     731           (DOTIMES (I 4) (FUNCALL STREAM ':TYO 0))
     732           ;; Write column position adjust as 0.
     733           (FUNCALL STREAM ':TYO 0)
     734           ;; Write baseline and height into second header word.
     735           (FUNCALL STREAM ':TYO (FONT-BASELINE FONT))
     736           (WRITE-KST-HALFWORD STREAM (FONT-CHAR-HEIGHT FONT))
     737           ;; Then write out all the characters.
     738           (LET (KERN-TABLE CHAR-WIDTH-TABLE CHARS-EXIST-TABLE
     739                 WORD-POS BIT-POS BYTE-COUNT BYTE
     740                 CHAR-RASTER-WIDTH BYTE-LIST BYTE-LIST-HEAD)
     741             (SETQ KERN-TABLE (FONT-LEFT-KERN-TABLE FONT)
     742                   CHAR-WIDTH-TABLE (FONT-CHAR-WIDTH-TABLE FONT))
     743             (ERRSET (SETQ CHARS-EXIST-TABLE (FONT-CHARS-EXIST-TABLE FONT)) NIL)
     744             (DOTIMES (CHAR-CODE FONT-LENGTH)
     745               (AND CHARS-EXIST-TABLE
     746                    (ZEROP (AREF CHARS-EXIST-TABLE CHAR-CODE))
     747                    (GO SKIP-CHAR))
     748               ;; Each char must start with a word containing a 1.
     749               (WRITE-KST-HALFWORD STREAM 0)
     750               (WRITE-KST-HALFWORD STREAM 1)
     751               ;; left kern and char code fill the next word.
     752               (WRITE-KST-HALFWORD STREAM
     753                                   (OR (AND KERN-TABLE (AREF KERN-TABLE CHAR-CODE)) 0))
     754               (WRITE-KST-HALFWORD STREAM CHAR-CODE)
     755               ;; Raster width and char width are the next word.
     756               (SETQ CHAR-RASTER-WIDTH (MAX 1 (FONT-CHAR-MIN-RASTER-WIDTH FONT CHAR-CODE)))
     757               (WRITE-KST-HALFWORD STREAM CHAR-RASTER-WIDTH)
     758               (WRITE-KST-HALFWORD STREAM
     759                                   (COND (CHAR-WIDTH-TABLE
     760                                          (OR (AREF CHAR-WIDTH-TABLE CHAR-CODE) 0))
     761                                         (T (FONT-CHAR-WIDTH FONT))))
     762               ;; Write out the bits of the character
     763               ;; Word-pos and bit-pos are used to point at a bit in the font.
     764               (SETQ WORD-POS (* (FONT-WORDS-PER-CHAR FONT) CHAR-CODE))
     765               (SETQ BIT-POS 0 BYTE-COUNT 0)
     766               ;; Byte-list and its head are used to accumulate 4 bytes
     767               ;; and then output them at once as a word.
     768               ;; This is needed because the stream wants 9-bit bytes.
     769               (SETQ BYTE-LIST-HEAD (LIST NIL NIL NIL NIL))
     770               (SETQ BYTE-LIST BYTE-LIST-HEAD)
     771               (COND ((NOT (ZEROP CHAR-RASTER-WIDTH))
     772                      (DOTIMES (VPOS (FONT-CHAR-HEIGHT FONT))
     773                        ;; Prepare to extract next row of char from font.
     774                        (AND (> (+ BIT-POS (FONT-RASTER-WIDTH FONT)) 32.)
     775                             (SETQ WORD-POS (1+ WORD-POS) BIT-POS 0))
     776                        (SETQ BYTE 0)
     777                        ;; Get the row a bit at a time and fill up 8-bit bytes.
     778                        ;; Output the bytes when full.  Output the excess at the end.
     779                        ;; Count the bytes output with byte-count
     780                        (DOTIMES (HPOS CHAR-RASTER-WIDTH)
     781                          (COND ((AND (= (\ HPOS 8) 0) (NOT (ZEROP HPOS)))
     782                                 (SETQ BYTE-COUNT (1+ BYTE-COUNT))
     783                                 (SETQ BYTE-LIST
     784                                       (WRITE-KST-BYTE STREAM BYTE BYTE-LIST BYTE-LIST-HEAD))
     785                                 (SETQ BYTE 0)))
     786                          (OR (
     787 VPOS (FONT-RASTER-HEIGHT FONT))
     788                              (SETQ BYTE (+ BYTE (LSH (AREF FONT
     789                                                            (+ (* 32. WORD-POS) HPOS BIT-POS))
     790                                                      (\ HPOS 8))))))
     791                        (SETQ BYTE-LIST (WRITE-KST-BYTE STREAM BYTE BYTE-LIST BYTE-LIST-HEAD))
     792                        (SETQ BYTE-COUNT (1+ BYTE-COUNT))
     793                        (SETQ BIT-POS (+ BIT-POS (FONT-RASTER-WIDTH FONT))))
     794                      ;; Pad to a word boundary.
     795                      (DO () ((ZEROP (\ BYTE-COUNT 4)))
     796                        (SETQ BYTE-LIST (WRITE-KST-BYTE STREAM 0 BYTE-LIST BYTE-LIST-HEAD))
     797                        (SETQ BYTE-COUNT (1+ BYTE-COUNT)))))
     798               SKIP-CHAR)
     799             ;; Mark end of file with two -1 words.
     800             (DOTIMES (I 8)
     801               (FUNCALL STREAM ':TYO -1)))
     802           (FUNCALL STREAM ':CLOSE)
     803           (FUNCALL STREAM ':TRUENAME)))))
     804
     805
     806(DEFUN WRITE-FONT-DESCRIPTOR-INTO-KST (FD &OPTIONAL FILENAME
     807                                          &AUX (FONT-LENGTH (ARRAY-ACTIVE-LENGTH FD)))
     808  (SETQ FILENAME (GET-OUTPUT-FILENAME-FROM-FONT-DESCRIPTOR FD FILENAME "KST"))
     809  (WITH-OPEN-FILE (STREAM FILENAME '(:FIXNUM :OUT :BYTE-SIZE 9.))
    658810    ;; Write KSTID as 0.
    659     (dotimes (i 4) (funcall stream ':tyo 0))
     811    (DOTIMES (I 4) (FUNCALL STREAM ':TYO 0))
    660812    ;; Write column position adjust as 0.
    661     (funcall stream ':tyo 0)
     813    (FUNCALL STREAM ':TYO 0)
    662814    ;; Write baseline and height into second header word.
    663     (funcall stream ':tyo (fd-baseline fd))
    664     (write-kst-halfword stream (fd-line-spacing fd))
     815    (FUNCALL STREAM ':TYO (FD-BASELINE FD))
     816    (WRITE-KST-HALFWORD STREAM (FD-LINE-SPACING FD))
    665817    ;; Then write out all the characters.
    666     (let (cd char-height byte-count byte byte-list byte-list-head)
    667        (dotimes (char-code 200)
    668           (cond ((and (setq cd (ar-1 fd char-code))
     818    (LET (CD CHAR-HEIGHT BYTE-COUNT BYTE BYTE-LIST BYTE-LIST-HEAD)
     819       (DOTIMES (CHAR-CODE FONT-LENGTH)
     820          (COND ((AND (SETQ CD (AREF FD CHAR-CODE))
    669821                      ;; Wide fonts without chars-exist-tables can have 0-width chars.
    670                       (or (not (zerop (array-dimension-n 2 cd)))
    671                           (not (zerop (cd-char-width cd)))))
     822                      (OR (NOT (ZEROP (ARRAY-DIMENSION-N 2 CD)))
     823                          (NOT (ZEROP (CD-CHAR-WIDTH CD)))))
    672824            ;; Each char must start with a word containing a 1.
    673             (write-kst-halfword stream 0)
    674             (write-kst-halfword stream 1)
     825            (WRITE-KST-HALFWORD STREAM 0)
     826            (WRITE-KST-HALFWORD STREAM 1)
    675827            ;; left kern and char code fill the next word.
    676             (write-kst-halfword stream (cd-char-left-kern cd))
    677             (write-kst-halfword stream char-code)
     828            (WRITE-KST-HALFWORD STREAM (CD-CHAR-LEFT-KERN CD))
     829            (WRITE-KST-HALFWORD STREAM CHAR-CODE)
    678830            ;; Raster width and char width are the next word.
    679             (write-kst-halfword stream (array-dimension-n 2 cd))
    680             (write-kst-halfword stream (cd-char-width cd))
     831            (WRITE-KST-HALFWORD STREAM (ARRAY-DIMENSION-N 2 CD))
     832            (WRITE-KST-HALFWORD STREAM (CD-CHAR-WIDTH CD))
    681833            ;; Write out the bits of the character
    682834            ;; Byte-list and its head are used to accumulate 4 bytes
    683835            ;; and then output them at once as a word.
    684836            ;; This is needed because the stream wants 9-bit bytes.
    685             (setq byte-list-head (list nil nil nil nil))
    686             (setq byte-list byte-list-head)
    687             (setq byte-count 0)
    688             (setq char-height (array-dimension-n 1 cd))
    689             (and (> char-height (fd-line-spacing fd))
    690                  (ferror nil "Character ~C height exceeds font line height in KST file"
    691                          char-code))
    692             (dotimes (vpos (fd-line-spacing fd))
    693                ;; Prepare to extract next row of char from font.
    694                (setq byte 0)
    695                ;; Get the row a bit at a time and fill up 8-bit bytes.
    696                ;; Output the bytes when full.  Output the excess at the end.
    697                ;; Count the bytes output with byte-count
    698                (dotimes (hpos (array-dimension-n 2 cd))
    699                    (cond ((and (= (\ hpos 8) 0) (not (zerop hpos)))
    700                           (setq byte-count (1+ byte-count))
    701                           (setq byte-list
    702                                 (write-kst-byte stream byte byte-list byte-list-head))
    703                           (setq byte 0)))
    704                    (or (
    705  vpos char-height)
    706                        (setq byte (+ byte (lsh (ar-2 cd vpos hpos) (\ hpos 8))))))
    707                (setq byte-count (1+ byte-count))
    708                (setq byte-list (write-kst-byte stream byte byte-list byte-list-head)))
    709             ;; Pad to a word boundary.
    710             (do () ((zerop (\ byte-count 4)))
    711                (setq byte-list (write-kst-byte stream 0 byte-list byte-list-head))
    712                (setq byte-count (1+ byte-count))))))
     837            (SETQ BYTE-LIST-HEAD (LIST NIL NIL NIL NIL))
     838            (SETQ BYTE-LIST BYTE-LIST-HEAD)
     839            (SETQ BYTE-COUNT 0)
     840            (SETQ CHAR-HEIGHT (ARRAY-DIMENSION-N 1 CD))
     841            (AND (> CHAR-HEIGHT (FD-LINE-SPACING FD))
     842                 (FERROR NIL "Character ~C height exceeds font line height in KST file"
     843                         CHAR-CODE))
     844            (COND ((NOT (ZEROP (ARRAY-DIMENSION-N 2 CD)))
     845                   (DOTIMES (VPOS (FD-LINE-SPACING FD))
     846                     ;; Prepare to extract next row of char from font.
     847                     (SETQ BYTE 0)
     848                     ;; Get the row a bit at a time and fill up 8-bit bytes.
     849                     ;; Output the bytes when full.  Output the excess at the end.
     850                     ;; Count the bytes output with byte-count
     851                     (DOTIMES (HPOS (ARRAY-DIMENSION-N 2 CD))
     852                       (COND ((AND (= (\ HPOS 8) 0) (NOT (ZEROP HPOS)))
     853                              (SETQ BYTE-COUNT (1+ BYTE-COUNT))
     854                              (SETQ BYTE-LIST
     855                                    (WRITE-KST-BYTE STREAM BYTE BYTE-LIST BYTE-LIST-HEAD))
     856                              (SETQ BYTE 0)))
     857                       (OR (
     858 VPOS CHAR-HEIGHT)
     859                           (SETQ BYTE (+ BYTE (LSH (AREF CD VPOS HPOS) (\ HPOS 8))))))
     860                     (SETQ BYTE-LIST (WRITE-KST-BYTE STREAM BYTE BYTE-LIST BYTE-LIST-HEAD))
     861                     (SETQ BYTE-COUNT (1+ BYTE-COUNT)))
     862                   ;; Pad to a word boundary.
     863                   (DO () ((ZEROP (\ BYTE-COUNT 4)))
     864                     (SETQ BYTE-LIST (WRITE-KST-BYTE STREAM 0 BYTE-LIST BYTE-LIST-HEAD))
     865                     (SETQ BYTE-COUNT (1+ BYTE-COUNT))))))))
    713866       ;; Mark end of file with two -1 words.
    714        (dotimes (i 8)
    715             (funcall stream ':tyo -1)))
    716     (close stream))
     867       (DOTIMES (I 8)
     868            (FUNCALL STREAM ':TYO -1)))
     869    (FUNCALL STREAM ':CLOSE)
     870    (FUNCALL STREAM ':TRUENAME)))
    717871
    718872
     
    721875;; Byte-list-head should be a list of length 4 we can clobber.
    722876;; byte-list should initially be the same thing;  we return a new value to set it to.
    723 (defun write-kst-byte (stream byte byte-list byte-list-head)
    724     (rplaca byte-list byte)
    725     (pop byte-list)
    726     (cond ((null byte-list)
    727            (setq byte-list byte-list-head)
    728            (write-kst-halfword stream
    729                   (+ (lsh (first byte-list) 10.)
    730                      (lsh (second byte-list) 2.)
    731                      (ldb 0602 (third byte-list))))
    732            (write-kst-halfword stream
    733                   (+ (lsh (ldb 0006 (third byte-list)) 12.)
    734                      (lsh (fourth byte-list) 4)))))
    735     byte-list)
    736 
    737 (defun write-kst-halfword (stream halfword)
    738     (funcall stream ':tyo (ldb 1111 halfword))
    739     (funcall stream ':tyo (ldb 0011 halfword)))
     877(DEFUN WRITE-KST-BYTE (STREAM BYTE BYTE-LIST BYTE-LIST-HEAD)
     878  (RPLACA BYTE-LIST BYTE)
     879  (POP BYTE-LIST)
     880  (COND ((NULL BYTE-LIST)
     881         (SETQ BYTE-LIST BYTE-LIST-HEAD)
     882         (WRITE-KST-HALFWORD STREAM
     883                             (+ (LSH (FIRST BYTE-LIST) 10.)
     884                                (LSH (SECOND BYTE-LIST) 2.)
     885                                (LDB 0602 (THIRD BYTE-LIST))))
     886         (WRITE-KST-HALFWORD STREAM
     887                             (+ (LSH (LDB 0006 (THIRD BYTE-LIST)) 12.)
     888                                (LSH (FOURTH BYTE-LIST) 4)))))
     889  BYTE-LIST)
     890
     891(DEFUN WRITE-KST-HALFWORD (STREAM HALFWORD)
     892  (FUNCALL STREAM ':TYO (LDB 1111 HALFWORD))
     893  (FUNCALL STREAM ':TYO (LDB 0011 HALFWORD)))
    740894
    741895;; Compute the smallest raster width needed to store the specified char
    742896;; as defined by the specified font.
    743897;; low-level means we are looking at one sub-character in a wide font.
    744 (defun font-char-min-raster-width (font char-code &optional low-level
    745                                         &aux bit-pos word-pos tem
    746                                         min-raster-width f-raster-width raster-height)
    747     (cond ((and (not low-level)
    748                 (setq tem (font-indexing-table font)))
     898(DEFUN FONT-CHAR-MIN-RASTER-WIDTH (FONT CHAR-CODE
     899                                   &OPTIONAL LOW-LEVEL
     900                                   &AUX BIT-POS WORD-POS TEM
     901                                        MIN-RASTER-WIDTH F-RASTER-WIDTH RASTER-HEIGHT)
     902    (COND ((AND (NOT LOW-LEVEL)
     903                (SETQ TEM (FONT-INDEXING-TABLE FONT)))
    749904           ;; If it's a wide font, go by the number of vertical stripes,
    750905           ;; but also see how wide the rightmost stripe really needs to be.
    751            (max 0
    752                 (+ (* 32. (- (ar-1 tem (1+ char-code)) (ar-1 tem char-code)))
    753                    -32.
    754                    (font-char-min-raster-width font (1- (ar-1 tem (1+ char-code))) t))))
    755           (t (setq word-pos (* char-code (font-words-per-char font))
    756                    bit-pos 0
    757                    min-raster-width 0
    758                    f-raster-width (font-raster-width font)
    759                    raster-height (font-raster-height font))
    760              (dotimes (vpos raster-height)
    761                  (and (> (+ bit-pos f-raster-width) 32.)
    762                       (setq bit-pos 0 word-pos (1+ word-pos)))
    763                  (do ((hpos 0 (1+ hpos)) (index (+ bit-pos (lsh word-pos 5)) (1+ index)))
    764                      ((= hpos f-raster-width))
    765                     (or (zerop (ar-1 font index))
    766                         (setq min-raster-width (max (1+ hpos) min-raster-width))))
    767                  (setq bit-pos (+ f-raster-width bit-pos)))
    768              min-raster-width)))
     906           (LET ((START-IDX (AREF TEM CHAR-CODE))
     907                 (END-IDX (AREF TEM (1+ CHAR-CODE))))
     908             (IF (= START-IDX END-IDX)
     909                 0
     910                 (MAX 0
     911                      (+ (* 32. (- END-IDX START-IDX))
     912                         -32.
     913                         (FONT-CHAR-MIN-RASTER-WIDTH FONT (1- END-IDX) T))))))
     914          (T (SETQ WORD-POS (* CHAR-CODE (FONT-WORDS-PER-CHAR FONT))
     915                   BIT-POS 0
     916                   MIN-RASTER-WIDTH 0
     917                   F-RASTER-WIDTH (FONT-RASTER-WIDTH FONT)
     918                   RASTER-HEIGHT (FONT-RASTER-HEIGHT FONT))
     919             (DOTIMES (VPOS RASTER-HEIGHT)
     920                 (AND (> (+ BIT-POS F-RASTER-WIDTH) 32.)
     921                      (SETQ BIT-POS 0 WORD-POS (1+ WORD-POS)))
     922                 (DO ((HPOS 0 (1+ HPOS)) (INDEX (+ BIT-POS (LSH WORD-POS 5)) (1+ INDEX)))
     923                     ((= HPOS F-RASTER-WIDTH))
     924                    (OR (ZEROP (AREF FONT INDEX))
     925                        (SETQ MIN-RASTER-WIDTH (MAX (1+ HPOS) MIN-RASTER-WIDTH))))
     926                 (SETQ BIT-POS (+ F-RASTER-WIDTH BIT-POS)))
     927             MIN-RASTER-WIDTH)))
    769928
    770929
    771930;; ALTO .AL format
     931;;;??? Not yet converted to load more than 200 chars into a font.
     932
    772933;; Load an ALTO font file into a font, the easy way, via a font descriptor
    773934(DEFUN READ-AL-INTO-FONT (FILENAME &OPTIONAL FONTNAME)
    774   (SETQ FILENAME (FS:FILE-PARSE-NAME FILENAME NIL T ':AL))
    775   (OR FONTNAME (SETQ FONTNAME (FUNCALL FILENAME ':NAME)))
    776   (AND (STRINGP FONTNAME) (SETQ FONTNAME (INTERN FONTNAME "FONTS")))
     935  (MULTIPLE-VALUE (FILENAME FONTNAME)
     936    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AL"))
    777937  (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME
    778938                                     (READ-AL-INTO-FONT-DESCRIPTOR FILENAME FONTNAME))
    779   (SYMEVAL FONTNAME))
     939  FONTNAME)
    780940
    781941;; Load an ALTO font file into a font descriptor
    782942(DEFUN READ-AL-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME
    783                                               &AUX FD STREAM ARRAY LINE-HEIGHT)
    784   (SETQ FILENAME (FS:FILE-PARSE-NAME FILENAME NIL T ':AL))
    785   (OR FONTNAME (SETQ FONTNAME (FUNCALL FILENAME ':NAME)))
    786   (AND (STRINGP FONTNAME) (SETQ FONTNAME (INTERN FONTNAME "FONTS")))
     943                                     &AUX FD ARRAY LINE-HEIGHT PROPORTIONAL MAX-WIDTH)
     944  (MULTIPLE-VALUE (FILENAME FONTNAME)
     945    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AL"))
    787946  (SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME))
    788947  (SETF (FD-NAME FD) FONTNAME)
    789   (SETQ STREAM (OPEN FILENAME '(:IN :FIXNUM)))
    790   (UNWIND-PROTECT
    791    (PROGN
     948  (WITH-OPEN-FILE (STREAM FILENAME '(:IN :FIXNUM))
    792949    (SETQ LINE-HEIGHT (FUNCALL STREAM ':TYI))
    793950    (SETF (FD-LINE-SPACING FD) LINE-HEIGHT)
    794951    (SETF (FD-BLINKER-HEIGHT FD) LINE-HEIGHT)
    795952    (LET ((BASELINE-AND-MAX-WIDTH (FUNCALL STREAM ':TYI)))
     953      (SETQ PROPORTIONAL (LDB-TEST 1701 BASELINE-AND-MAX-WIDTH))
    796954      (SETF (FD-BASELINE FD) (LDB 1007 BASELINE-AND-MAX-WIDTH))
    797       (SETF (FD-SPACE-WIDTH FD) (LDB 0010 BASELINE-AND-MAX-WIDTH)))
    798     (SETQ ARRAY (MAKE-ARRAY NIL 'ART-16B 1000. NIL '(0)))
     955      (SETF (FD-SPACE-WIDTH FD) (SETQ MAX-WIDTH (LDB 0010 BASELINE-AND-MAX-WIDTH))))
     956    (SETQ ARRAY (MAKE-ARRAY 1000. ':TYPE 'ART-16B ':LEADER-LIST '(0)))
    799957    (DO CH (FUNCALL STREAM ':TYI) (FUNCALL STREAM ':TYI) (NULL CH)
    800958      (ARRAY-PUSH-EXTEND ARRAY CH)))
    801    (FUNCALL STREAM ':CLOSE))
    802959  (DO ((CH 0 (1+ CH))
    803960       (CD)
    804961       (CHAR-WIDTH))
    805962      ((
    806  CH 200))
     963 CH 200))       ;Alto font could have 400 characters, our fonts don't yet
    807964    (SETQ CHAR-WIDTH 0)
    808965    (DO ((IDX CH)
     
    814971          (SETQ CHAR-WIDTH (+ CHAR-WIDTH 16.)
    815972                IDX XW)
    816           (SETQ CHAR-WIDTH (+ CHAR-WIDTH XW))
    817           (RETURN)))
    818     (SETQ CD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (NIL ART-1B (LIST LINE-HEIGHT CHAR-WIDTH))))
     973          (RETURN (SETQ CHAR-WIDTH (+ CHAR-WIDTH XW)))))
     974    (SETQ CD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (:TYPE ART-1B
     975                                               :LENGTH (LIST LINE-HEIGHT CHAR-WIDTH))))
    819976    (SETF (CD-CHAR-WIDTH CD) CHAR-WIDTH)
    820977    (AND (= CH #\SP) (SETF (FD-SPACE-WIDTH FD) CHAR-WIDTH))
     
    836993      ((= I IDX))
    837994    (DO ((BITS (AREF ARRAY I) (LSH BITS 1))
    838          (X XOFF (1+ X)))
    839         ((ZEROP BITS))
     995         (X XOFF (1+ X))
     996         (CW (CD-CHAR-WIDTH CD)))
     997        ((OR (ZEROP BITS) (
     998 X CW)))                ;Can be garbage to right of raster
    840999      (AND (BIT-TEST 100000 BITS)
    8411000           (ASET 1 CD Y X))))
     
    8431002      (READ-AL-INTO-FONT-DESCRIPTOR-1 CD ARRAY (// XW 2) (+ XOFF 16.))))
    8441003
    845 
     1004(DEFUN WRITE-FONT-INTO-AL (FONTNAME &OPTIONAL FILENAME)
     1005  (MULTIPLE-VALUE (FONTNAME FILENAME)
     1006    (GET-OUTPUT-FILENAME-AND-FONTNAME FONTNAME FILENAME "AL"))
     1007  (LET ((FD (FONT-NAME-FONT-DESCRIPTOR FONTNAME)))
     1008    (WRITE-FONT-DESCRIPTOR-INTO-AL FD FILENAME)))
     1009
     1010;I don't think this does the desired thing for variable-width ("proportional") fonts
     1011(DEFUN WRITE-FONT-DESCRIPTOR-INTO-AL (FD &OPTIONAL FILENAME &AUX ARRAY CARRAY LINE-HEIGHT)
     1012  (SETQ FILENAME (GET-OUTPUT-FILENAME-FROM-FONT-DESCRIPTOR FD FILENAME "AL"))
     1013  (WITH-OPEN-FILE (STREAM FILENAME '(:OUT :FIXNUM))
     1014    (FUNCALL STREAM ':TYO (SETQ LINE-HEIGHT (FD-LINE-SPACING FD)))
     1015    (FUNCALL STREAM ':TYO (DPB (FD-BASELINE FD) 1007 (FD-SPACE-WIDTH FD)))
     1016    (SETQ ARRAY (MAKE-ARRAY 1000. ':TYPE 'ART-16B ':LEADER-LIST '(0))   ;Data array
     1017          CARRAY (MAKE-ARRAY 400 ':TYPE 'ART-16B ':LEADER-LIST '(400))) ;Non self-rel chars
     1018    ;; Store dummy
     1019    (ARRAY-PUSH-EXTEND ARRAY 1)
     1020    (ARRAY-PUSH-EXTEND ARRAY 0)
     1021    (LOOP FOR CH FROM 0 BELOW 200
     1022          AS CD = (AREF FD CH)
     1023          AS CHAR-WIDTH = (CD-CHAR-WIDTH CD)
     1024          DO (LOOP WITH CH = CH WITH (XW HD-XH)
     1025                   FOR XOFF FROM 0 BY 16. BELOW CHAR-WIDTH
     1026                   DO (SETQ HD-XH (WRITE-AL-COLUMN CD XOFF ARRAY))
     1027                      (ASET (ARRAY-LEADER ARRAY 0) CARRAY CH)
     1028                      (SETQ XW (IF (> (- CHAR-WIDTH XOFF) 16.)
     1029                                   (* (SETQ CH (PROG1 (ARRAY-LEADER CARRAY 0)
     1030                                                      (ARRAY-PUSH-EXTEND CARRAY 0)))
     1031                                      2)
     1032                                   (1+ (* (- CHAR-WIDTH XOFF) 2))))
     1033                      (ARRAY-PUSH-EXTEND ARRAY XW)
     1034                      (ARRAY-PUSH-EXTEND ARRAY HD-XH)))
     1035    (LOOP FOR I FROM 0 BELOW (ARRAY-ACTIVE-LENGTH CARRAY)       ;Make self-relative
     1036          DO (ASET (- (+ (AREF CARRAY I) (ARRAY-ACTIVE-LENGTH CARRAY)) I)
     1037                   CARRAY I))
     1038    (FUNCALL STREAM ':STRING-OUT CARRAY)
     1039    (FUNCALL STREAM ':STRING-OUT ARRAY)
     1040    (FUNCALL STREAM ':CLOSE)
     1041    (FUNCALL STREAM ':TRUENAME)))
     1042
     1043(DEFUN WRITE-AL-COLUMN-ROW (CD XOFF Y)
     1044  (LOOP WITH STUFF = 0
     1045        FOR X FROM (+ XOFF (CD-CHAR-LEFT-KERN CD)) BELOW (ARRAY-DIMENSION-N 2 CD)
     1046        AS MASK = 100000 THEN (LSH MASK -1) UNTIL (ZEROP MASK)
     1047        WHEN (AND (NOT (MINUSP X)) (NOT (ZEROP (AREF CD Y X))))
     1048          DO (SETQ STUFF (LOGIOR STUFF MASK))
     1049        FINALLY (RETURN STUFF)))
     1050
     1051(DEFUN WRITE-AL-COLUMN (CD XOFF ARRAY &AUX (HD 0) (XC 0))
     1052  (LOOP FOR Y FROM 0 TO (LOOP FOR Y FROM (1- (ARRAY-DIMENSION-N 1 CD)) DOWNTO 0
     1053                              WHILE (ZEROP (WRITE-AL-COLUMN-ROW CD XOFF Y))
     1054                              FINALLY (RETURN Y))
     1055        AS ROW = (WRITE-AL-COLUMN-ROW CD XOFF Y)
     1056        DO (IF (AND (ZEROP ROW) (ZEROP XC))
     1057               (SETQ HD (1+ HD))
     1058               (ARRAY-PUSH-EXTEND ARRAY ROW)
     1059               (SETQ XC (1+ XC))))
     1060  (DPB HD 1010 XC))
     1061
     1062
     1063;; ALTO .KS format
     1064;; Load a kerned-strike file into a font
     1065(DEFUN READ-KS-INTO-FONT (FILENAME &OPTIONAL FONTNAME)
     1066  (MULTIPLE-VALUE (FILENAME FONTNAME)
     1067    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "KS"))
     1068  (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME
     1069        (READ-KS-INTO-FONT-DESCRIPTOR FILENAME FONTNAME))
     1070  FONTNAME)
     1071
     1072;; Load a kerned-strike font file into a font descriptor
     1073(DEFUN READ-KS-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME
     1074                                              &AUX FD LINE-HEIGHT MAX-WIDTH WD FIXED-WIDTH
     1075                                              MIN-CHAR MAX-CHAR STRIKE-NWDS FBBOX
     1076                                              ASCENT DESCENT WORDS-PER-RASTER
     1077                                              BITMAP BITMAP16 INDEX)
     1078  (MULTIPLE-VALUE (FILENAME FONTNAME)
     1079    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "KS"))
     1080  (SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME))
     1081  (SETF (FD-NAME FD) FONTNAME)
     1082  (WITH-OPEN-FILE (STREAM FILENAME '(:IN :FIXNUM))
     1083    (SETQ WD (FUNCALL STREAM ':TYI))
     1084    (OR (BIT-TEST 100000 WD) (FERROR NIL "Not /"new format/""))
     1085    (AND (BIT-TEST 40000 WD) (FERROR NIL "StrikeIndex format not understood"))
     1086    (SETQ FIXED-WIDTH (BIT-TEST 20000 WD))
     1087    (OR (BIT-TEST 10000 WD) (FERROR NIL "PlainStrike format not understood"))
     1088    (SETQ MIN-CHAR (FUNCALL STREAM ':TYI) MAX-CHAR (FUNCALL STREAM ':TYI))
     1089    (SETQ MAX-WIDTH (FUNCALL STREAM ':TYI))
     1090    (SETQ FBBOX (FUNCALL STREAM ':TYI))         ;Font bounding-box X-offset
     1091    (IF (BIT-TEST 100000 FBBOX) (SETQ FBBOX (- FBBOX 200000)))  ;signed
     1092    (DOTIMES (I 3) (FUNCALL STREAM ':TYI))      ;Ignore rest of font bounding box
     1093    (SETQ STRIKE-NWDS (FUNCALL STREAM ':TYI)
     1094          ASCENT (FUNCALL STREAM ':TYI)
     1095          DESCENT (FUNCALL STREAM ':TYI))
     1096    (SETQ LINE-HEIGHT (+ ASCENT DESCENT))
     1097    (FUNCALL STREAM ':TYI)                      ;Ignore xoffset
     1098    (SETQ WORDS-PER-RASTER (FUNCALL STREAM ':TYI))
     1099    (SETF (FD-LINE-SPACING FD) LINE-HEIGHT)
     1100    (SETF (FD-BLINKER-HEIGHT FD) LINE-HEIGHT)
     1101    (SETF (FD-BASELINE FD) ASCENT)
     1102    (SETF (FD-SPACE-WIDTH FD) MAX-WIDTH)
     1103    ;; Now copy the bitmap (the goddamn words are bit-reversed!)
     1104    (SETQ BITMAP16 (MAKE-ARRAY (LIST WORDS-PER-RASTER LINE-HEIGHT) ':TYPE 'ART-16B)
     1105          BITMAP (MAKE-ARRAY (LIST (* WORDS-PER-RASTER 16.) LINE-HEIGHT)
     1106                             ':TYPE 'ART-1B ':DISPLACED-TO BITMAP16))
     1107    (DOTIMES (Y LINE-HEIGHT)
     1108      (DOTIMES (X WORDS-PER-RASTER)
     1109        (ASET (FUNCALL STREAM ':TYI) BITMAP16 (- WORDS-PER-RASTER X 1) Y)))
     1110    ;; Copy the index segment
     1111    (SETQ INDEX (MAKE-ARRAY (+ (- MAX-CHAR MIN-CHAR) 3) ':TYPE 'ART-16B))
     1112    (DOTIMES (I (ARRAY-LENGTH INDEX))
     1113      (ASET (FUNCALL STREAM ':TYI) INDEX I))
     1114    ;; Read the width table and make the characters
     1115    (LOOP FOR CH FROM MIN-CHAR TO (MIN (1+ MAX-CHAR) 177) WITH CD
     1116          AS XLEFT = (AREF INDEX (- CH MIN-CHAR))
     1117          AS XRIGHT = (AREF INDEX (1+ (- CH MIN-CHAR)))
     1118          AS WDE = (FUNCALL STREAM ':TYI)
     1119          UNLESS (= WDE 177777)         ;Nonexistent character
     1120          DO (SETQ CD (MAKE-CHAR-DESCRIPTOR
     1121                        MAKE-ARRAY (:TYPE ART-1B
     1122                                    :LENGTH (LIST LINE-HEIGHT (- XRIGHT XLEFT)))))
     1123             (SETF (CD-CHAR-WIDTH CD) (LDB 0010 WDE))
     1124             (AND (= CH #\SP) (SETF (FD-SPACE-WIDTH FD) (CD-CHAR-WIDTH CD)))
     1125             (SETF (CD-CHAR-LEFT-KERN CD) (- (+ (LDB 1010 WDE) FBBOX)))
     1126             (ASET CD FD CH)
     1127             (LOOP FOR Y FROM 0 BELOW LINE-HEIGHT DO
     1128               (LOOP FOR X FROM 0 BELOW (- XRIGHT XLEFT)
     1129                     AS BMX DOWNFROM (- (ARRAY-DIMENSION-N 1 BITMAP) XLEFT 1)
     1130                     DO (ASET (AREF BITMAP BMX Y) CD Y X))))
     1131  (SETF (FD-FILL-POINTER FD) 200)
     1132  ;; Set width of blinker and space fields from the space character.
     1133  (SETF (FD-BLINKER-WIDTH FD) (FD-SPACE-WIDTH FD))
     1134  FD))
     1135
     1136
     1137;;; Some useful font munging functions
    8461138(DEFUN THICKEN-FONT-DESCRIPTOR (FD &OPTIONAL NEW-NAME &AUX LEN NFD)
    8471139  (OR NEW-NAME (SETQ NEW-NAME (INTERN (STRING-APPEND (FD-NAME FD) #/B) "FONTS")))
    848   (SETQ LEN (ARRAY-LENGTH FD)
    849         NFD (MAKE-FONT-DESCRIPTOR MAKE-ARRAY (NIL ART-Q LEN)
     1140  (SETQ LEN (ARRAY-ACTIVE-LENGTH FD)
     1141        NFD (MAKE-FONT-DESCRIPTOR MAKE-ARRAY (:TYPE 'ART-Q :LENGTH LEN)
     1142                                  FD-FILL-POINTER (FD-FILL-POINTER FD)
    8501143                                  FD-NAME NEW-NAME
    8511144                                  FD-LINE-SPACING (FD-LINE-SPACING FD)
     
    8611154         (LET ((WIDTH (ARRAY-DIMENSION-N 2 CD))
    8621155               (HEIGHT (ARRAY-DIMENSION-N 1 CD)))
    863            (SETQ NCD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (NIL ART-4B (LIST HEIGHT (1+ WIDTH)))
     1156           (SETQ NCD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (:TYPE 'ART-4B
     1157                                                       :LENGTH (LIST HEIGHT (1+ WIDTH)))
    8641158                                           CD-CHAR-WIDTH (1+ (CD-CHAR-WIDTH CD))
    8651159                                           CD-CHAR-LEFT-KERN (CD-CHAR-LEFT-KERN CD)))
     
    8711165  NFD)
    8721166
    873 (DEFUN THICKEN-FONT (FONT-SYMBOL &AUX FD NFD NFS NFNT)
    874   (SETQ FD (FONT-NAME-FONT-DESCRIPTOR FONT-SYMBOL))
    875   (SETQ NFD (THICKEN-FONT-DESCRIPTOR FD))
    876   (SETQ NFS (FD-NAME NFD))
    877   (SETQ NFNT (FONT-DESCRIPTOR-INTO-FONT NFD))
    878   (SET NFS NFNT)
    879   (PUTPROP NFS NFD 'FONT-DESCRIPTOR)
    880   (PUTPROP NFS NFNT 'FONT-DESCRIBED)
     1167(DEFUN THICKEN-FONT (FONT-SYMBOL &AUX FD NFD NFS)
     1168  (SETQ FD (FONT-NAME-FONT-DESCRIPTOR FONT-SYMBOL)
     1169        NFD (THICKEN-FONT-DESCRIPTOR FD)
     1170        NFS (FD-NAME NFD))
     1171  (FONT-NAME-SET-FONT-AND-DESCRIPTOR NFS NFD)
    8811172  NFS)
     1173
     1174(DEFUN UNTHICKEN-FONT-DESCRIPTOR (FD NEW-NAME &AUX LEN NFD)
     1175  (SETQ LEN (ARRAY-ACTIVE-LENGTH FD)
     1176        NFD (MAKE-FONT-DESCRIPTOR MAKE-ARRAY (:TYPE 'ART-Q :LENGTH LEN)
     1177                                  FD-FILL-POINTER (FD-FILL-POINTER FD)
     1178                                  FD-NAME NEW-NAME
     1179                                  FD-LINE-SPACING (FD-LINE-SPACING FD)
     1180                                  FD-BASELINE (FD-BASELINE FD)
     1181                                  FD-BLINKER-HEIGHT (FD-BLINKER-HEIGHT FD)
     1182                                  FD-BLINKER-WIDTH (FD-BLINKER-WIDTH FD)
     1183                                  FD-SPACE-WIDTH (FD-SPACE-WIDTH FD)))
     1184  (DO ((I 0 (1+ I))
     1185       (CD) (NCD))
     1186      ((
     1187 I LEN))
     1188    (AND (SETQ CD (AREF FD I))
     1189         (LET ((WIDTH (ARRAY-DIMENSION-N 2 CD))
     1190               (HEIGHT (ARRAY-DIMENSION-N 1 CD)))
     1191           (SETQ NCD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (:TYPE 'ART-4B
     1192                                                       :LENGTH (LIST HEIGHT WIDTH))
     1193                                           CD-CHAR-WIDTH (CD-CHAR-WIDTH CD)
     1194                                           CD-CHAR-LEFT-KERN (CD-CHAR-LEFT-KERN CD)))
     1195           (COPY-ARRAY-CONTENTS CD NCD)
     1196           ;110 100
     1197           (DOTIMES (J HEIGHT)
     1198             (LOOP FOR I FROM (1- WIDTH) ABOVE 0
     1199                   AS RIGHT = 0 THEN THIS
     1200                   AS THIS FIRST (AREF CD J I) THEN LEFT
     1201                   AS LEFT = (AREF CD J (1- I))
     1202                   WHEN (AND (= LEFT 1) (= THIS 1) (= RIGHT 0))
     1203                     DO (ASET 0 NCD J I)))
     1204           (ASET NCD NFD I))))
     1205  NFD)
     1206
     1207(DEFUN UNTHICKEN-FONT (FONT-SYMBOL NFS &AUX FD NFD)
     1208  (SETQ FD (FONT-NAME-FONT-DESCRIPTOR FONT-SYMBOL)
     1209        NFD (UNTHICKEN-FONT-DESCRIPTOR FD NFS))
     1210  (FONT-NAME-SET-FONT-AND-DESCRIPTOR NFS NFD)
     1211  NFS)
     1212
     1213(DEFUN ROTATE-FONT-DESCRIPTOR (FD &AUX LENGTH NFD)
     1214  (SETQ LENGTH (ARRAY-ACTIVE-LENGTH FD)
     1215        NFD (MAKE-FONT-DESCRIPTOR :MAKE-ARRAY (:LENGTH LENGTH)
     1216                                  FD-FILL-POINTER (FD-FILL-POINTER FD)
     1217                                  FD-NAME (INTERN (STRING-APPEND (FD-NAME FD) #/R) "FONTS")
     1218                                  FD-BASELINE (FD-SPACE-WIDTH FD)
     1219                                  FD-LINE-SPACING (FD-SPACE-WIDTH FD)
     1220                                  FD-BLINKER-HEIGHT (FD-BLINKER-WIDTH FD)
     1221                                  FD-BLINKER-WIDTH (FD-BLINKER-HEIGHT FD)
     1222                                  FD-SPACE-WIDTH (FD-LINE-SPACING FD)
     1223                                  FD-ROTATION 90.))
     1224  (LOOP FOR CH FROM 0 BELOW LENGTH
     1225        AS CD = (AREF FD CH)
     1226        WHEN CD
     1227        DO (ASET (ROTATE-CHAR-DESCRIPTOR CD) NFD CH))
     1228  NFD)
     1229
     1230(DEFUN ROTATE-CHAR-DESCRIPTOR (CD)
     1231  (LET* ((HEI (ARRAY-DIMENSION-N 1 CD))
     1232         (WID (ARRAY-DIMENSION-N 2 CD))
     1233         (NCD (MAKE-CHAR-DESCRIPTOR :MAKE-ARRAY (:LENGTH (LIST WID HEI)
     1234                                                         :TYPE (ARRAY-TYPE CD))
     1235                                    CD-CHAR-LEFT-KERN 0
     1236                                    CD-CHAR-WIDTH HEI)))
     1237    (LOOP FOR X FROM 0 BELOW WID
     1238          DO (LOOP FOR Y FROM 0 BELOW HEI
     1239                   DO (ASET (AREF CD Y X) NCD (- WID X 1) Y)))
     1240    NCD))
     1241
     1242(DEFUN ROTATE-FONT (FONT-SYMBOL &AUX FD NFD NFS)
     1243  (SETQ FD (FONT-NAME-FONT-DESCRIPTOR FONT-SYMBOL)
     1244        NFD (ROTATE-FONT-DESCRIPTOR FD)
     1245        NFS (FD-NAME NFD))
     1246  (FONT-NAME-SET-FONT-AND-DESCRIPTOR NFS NFD)
     1247  NFS)
     1248
     1249
     1250(DEFMACRO SIGN-EXTEND (16BIT-WORD)
     1251  `(LET ((WORD ,16BIT-WORD))
     1252     (IF (
     1253 WORD 100000)
     1254         (- WORD 200000)
     1255         WORD)))
     1256
     1257(DEFMACRO HIGH-BYTE (WORD)
     1258  `(LSH ,WORD -8))
     1259
     1260(DEFMACRO LOW-BYTE (WORD)
     1261  `(BOOLE 1 377 ,WORD))
     1262
     1263;Get next 16-bit word from input-file
     1264(DEFUN NEXT-WORD ()
     1265  (DECLARE (SPECIAL INPUT-FILE))
     1266  (FUNCALL INPUT-FILE ':TYI "Unexpected EOF on AC file"))
     1267
     1268;Read in an AC file as a Lisp machine font.
     1269(DEFUN READ-AC-INTO-FONT (FILENAME &OPTIONAL FONTNAME)
     1270  (MULTIPLE-VALUE (FILENAME FONTNAME)
     1271    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AC"))
     1272  (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME
     1273                                     (READ-AC-INTO-FONT-DESCRIPTOR FILENAME FONTNAME))
     1274  FONTNAME)
     1275
     1276(DEFUN READ-AC-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME
     1277                                              &AUX FAMILY-NAME FACE-CODE POINT-SIZE)
     1278  (DECLARE (SPECIAL INPUT-FILE))
     1279  (MULTIPLE-VALUE (FILENAME FONTNAME)
     1280    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AC"))
     1281  (WITH-OPEN-FILE (INPUT-FILE FILENAME '(:READ :FIXNUM))
     1282    (SETF (VALUES FAMILY-NAME FACE-CODE POINT-SIZE)
     1283          (PRESS:DECODE-FONT-NAME (STRING FONTNAME)))
     1284    (LET ((CODE-ALIST NIL)
     1285          (SEGMENT-DATA NIL)
     1286          FAMILY-CODE TEM SEGMENT
     1287          FD
     1288          (WD 0))
     1289      (SETQ WD (NEXT-WORD))
     1290      ;; Read IXN entries (type 1)
     1291      (DO () ((NOT (= (LSH WD -12.) 1)))
     1292        (LET ((CODE (NEXT-WORD))
     1293              (NAME (PRESS:BCPL-STRING 20. INPUT-FILE)))
     1294          (PUSH (CONS CODE NAME) CODE-ALIST))
     1295        (SETQ WD (NEXT-WORD)))
     1296      ;; Find out the code number for the font family to be used,
     1297      ;; either the specified one or the only one.
     1298      (COND (FAMILY-NAME
     1299             (OR (SETQ FAMILY-CODE (CAR (RASSOC FAMILY-NAME CODE-ALIST)))
     1300                 (FERROR NIL "Font family ~A not present in AC file" FAMILY-NAME)))
     1301            ((CDR CODE-ALIST)
     1302             (FERROR NIL "Font dictionary ~A: font family not specified" FILENAME))
     1303            (T (SETQ FAMILY-CODE (CAAR CODE-ALIST))))
     1304      ;; Read Index Entries (type 3) for AC segments.
     1305      (DO () ((NOT (= (LSH WD -12.) 3)))
     1306        (SETQ WD (NEXT-WORD))                   ;family,,face
     1307        (SETQ TEM
     1308              (LIST (HIGH-BYTE WD)              ;Family code number.
     1309                    (PRESS:DECODE-FACE (LOW-BYTE WD))   ;Face name
     1310                    (PROGN (SETQ WD (NEXT-WORD))        ;bc,,ec
     1311                           (HIGH-BYTE WD))      ;First code
     1312                    (LOW-BYTE WD)               ;Last code
     1313                    (NEXT-WORD)                 ;Size
     1314                    (NEXT-WORD)                 ;Rotation
     1315                    (+ (LSH (NEXT-WORD) 16.) (NEXT-WORD))       ;Segment SA
     1316                    (+ (LSH (NEXT-WORD) 16.) (NEXT-WORD))       ;Segment Len
     1317                    (NEXT-WORD)                 ;horiz resolution
     1318                    (NEXT-WORD)))               ;vert resolution
     1319        (AND (= (CAR TEM) FAMILY-CODE) (PUSH TEM SEGMENT-DATA))
     1320        (SETQ WD (NEXT-WORD)))
     1321      ;; Now should have type-0 entry (end of index)
     1322      (SELECTQ (LSH WD -12.)
     1323        (0 )
     1324        (5 (FERROR NIL "There are OrbitChars segments in this file -- I don't grok them"))
     1325        (OTHERWISE
     1326          (FERROR NIL "~O - Bullshit in file where type 0 IX expected" WD)))
     1327      ;; Now either there should be only one segment or the face code and size
     1328      ;; should have been specified.
     1329      (COND ((AND POINT-SIZE FACE-CODE)
     1330             (DOLIST (SEG SEGMENT-DATA)
     1331               (AND (STRING-EQUAL (CADR SEG) FACE-CODE)
     1332                    (= (// (+ 1270. (* (FIFTH SEG) 72.)) 2540.) POINT-SIZE)
     1333                    (RETURN (SETQ SEGMENT SEG))))
     1334             (OR SEGMENT (FERROR NIL "Font ~A not found in AC file" FONTNAME)))
     1335            ((CDR SEGMENT-DATA)
     1336             (FERROR "Font dictionary ~A: point size or face code not specified" FILENAME))
     1337            (T (SETQ SEGMENT (CAR SEGMENT-DATA)
     1338                     POINT-SIZE (// (+ 1270. (* (FIFTH SEGMENT) 72.)) 2540.))))
     1339      (FUNCALL INPUT-FILE ':SET-POINTER (SEVENTH SEGMENT))
     1340      (LET ((BC (THIRD SEGMENT))
     1341            (EC (FOURTH SEGMENT))
     1342            (BASELINE 0)
     1343            (XWIDTHS (MAKE-ARRAY 400))
     1344            (YWIDTHS (MAKE-ARRAY 400))
     1345            (BOX-X-OFFSET (MAKE-ARRAY 400))
     1346            (BOX-Y-OFFSET (MAKE-ARRAY 400))
     1347            (BOX-X-SIZE (MAKE-ARRAY 400))
     1348            (BOX-Y-SIZE (MAKE-ARRAY 400))
     1349            (CHAR-DATA-POSITION (MAKE-ARRAY 400))
     1350            LINE-HEIGHT)
     1351        ;; read in the widths info from the segment.
     1352        (DO ((I BC (1+ I))) ((> I EC))
     1353          (ASET (+ (SIGN-EXTEND (NEXT-WORD)) (// (NEXT-WORD) 65536.0))
     1354                XWIDTHS I)
     1355          (ASET (+ (SIGN-EXTEND (NEXT-WORD)) (// (NEXT-WORD) 65536.0))
     1356                YWIDTHS I)
     1357          (ASET (SIGN-EXTEND (NEXT-WORD)) BOX-X-OFFSET I)
     1358          (ASET (SIGN-EXTEND (NEXT-WORD)) BOX-Y-OFFSET I)
     1359          (ASET (SIGN-EXTEND (NEXT-WORD)) BOX-X-SIZE I)
     1360          (ASET (SIGN-EXTEND (NEXT-WORD)) BOX-Y-SIZE I))
     1361        ;; Read relative pointers to character data beginnings
     1362        ;; and convert them to absolute pointers within the file.
     1363        (DO ((I BC (1+ I))
     1364             (STARTING-POSITION (FUNCALL INPUT-FILE ':READ-POINTER)))
     1365            ((> I EC))
     1366          (SETF (AREF CHAR-DATA-POSITION I)
     1367                (+ (LSH (NEXT-WORD) 32.)
     1368                   (NEXT-WORD)
     1369                   STARTING-POSITION)))
     1370        (SETQ FONTNAME (STRING-APPEND (CDR (ASSQ FAMILY-CODE CODE-ALIST))
     1371                                      (FORMAT NIL "~D" POINT-SIZE)
     1372                                      (OR (SECOND SEGMENT) "")))
     1373        (SETQ FONTNAME (INTERN (STRING-UPCASE FONTNAME) "FONTS"))
     1374        (SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME
     1375                                       MAKE-ARRAY (:LENGTH (1+ EC))))
     1376        (SETF (FD-FILL-POINTER FD) (1+ EC))
     1377        (SETF (FD-VERT-RESOLUTION FD) (NTH 9 SEGMENT))
     1378        (SETF (FD-HORIZ-RESOLUTION FD) (NTH 8 SEGMENT))
     1379        (SETF (FD-ROTATION FD) (NTH 5 SEGMENT))
     1380        (DO ((HEIGHT 0)
     1381             (I BC (1+ I)))
     1382            ((> I EC)
     1383             (SETQ LINE-HEIGHT (+ HEIGHT BASELINE))
     1384             (SETF (FD-LINE-SPACING FD) LINE-HEIGHT)
     1385             (SETF (FD-BLINKER-HEIGHT FD) LINE-HEIGHT)
     1386             (SETF (FD-BASELINE FD) (- LINE-HEIGHT BASELINE)))
     1387          (COND (( (AREF BOX-Y-SIZE I) -1)
     1388                 (SETQ HEIGHT (MAX HEIGHT (+ (AREF BOX-Y-SIZE I) (AREF BOX-Y-OFFSET I))))))
     1389          (COND (( (AREF BOX-Y-SIZE I) -1)
     1390                 (SETQ BASELINE (MAX BASELINE (- (AREF BOX-Y-OFFSET I)))))))
     1391        (DO ((CH BC (1+ CH))
     1392             (CHAR-WIDTH)
     1393             (RASTER-HEIGHT)
     1394             (RASTER-WIDTH)
     1395             (CHAR-Y-OFFSET)
     1396             (WD)
     1397             (CD))
     1398            ((> CH EC))
     1399          (COND (( (AREF BOX-Y-SIZE CH) -1)
     1400                 (SETQ CHAR-WIDTH (AREF XWIDTHS CH))
     1401                 (SETQ RASTER-WIDTH (AREF BOX-X-SIZE CH))
     1402                 (SETQ RASTER-HEIGHT (AREF BOX-Y-SIZE CH))
     1403                 (SETQ CHAR-Y-OFFSET (AREF BOX-Y-OFFSET CH))
     1404                 (SETQ CD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (:TYPE ART-1B
     1405                                                            :LENGTH (LIST LINE-HEIGHT
     1406                                                                          RASTER-WIDTH))))
     1407                 (SETF (CD-CHAR-WIDTH CD) CHAR-WIDTH)
     1408                 (SETF (CD-CHAR-VERT-WIDTH CD) (AREF YWIDTHS CH))
     1409                 (AND (= CH #\SP) (SETF (FD-SPACE-WIDTH FD) CHAR-WIDTH))
     1410                 (SETF (CD-CHAR-LEFT-KERN CD) (- (AREF BOX-X-OFFSET CH)))
     1411                 ;; Store the CD in the font descriptor
     1412                 (ASET CD FD CH)
     1413                 ;; Verify that the relative pointer to this character's data was right.
     1414                 (OR (= (AREF CHAR-DATA-POSITION CH)
     1415                        (FUNCALL INPUT-FILE ':READ-POINTER))
     1416                     (FERROR NIL "Inconsistent character data pointer for character ~C" CH))
     1417                 ;; Skip a word of redundant info on raster height and width.
     1418                 (LET ((TEM (NEXT-WORD)))
     1419                   (OR (= TEM (DPB (// (+ RASTER-HEIGHT 17) 20) 1206 RASTER-WIDTH))
     1420                       (FERROR NIL
     1421        "Inconsistent raster size data at front of character bits for character ~C"
     1422                               CH)))
     1423                 ;; Raster lines go vertically up, leftmost line first.
     1424                 (DOTIMES (HPOS RASTER-WIDTH)
     1425                   ;; Read in the next vertical scan line.
     1426                   (DOTIMES (VPOS RASTER-HEIGHT)
     1427                     ;; If wd is exhausted, get next word into wd
     1428                     (COND ((ZEROP (\ VPOS 16.))
     1429                            (SETQ WD (NEXT-WORD))))
     1430                     (SETQ TEM (LDB 1701 (LSH WD (\ VPOS 16.))))
     1431                     (OR (
     1432 (+ VPOS BASELINE CHAR-Y-OFFSET) LINE-HEIGHT)
     1433                         (ASET TEM CD
     1434                               (- LINE-HEIGHT 1 (+ VPOS BASELINE CHAR-Y-OFFSET))
     1435                               HPOS)))))))
     1436        ;; Set width of blinker and space fields from the space character.
     1437        (SETF (FD-BLINKER-WIDTH FD) (FD-SPACE-WIDTH FD))
     1438        (OR (= (FUNCALL INPUT-FILE ':READ-POINTER)
     1439               (+ (NTH 6 SEGMENT) (NTH 7 SEGMENT)))
     1440            (FERROR NIL "Inconsistent data-length in index of AC file"))
     1441        FD))))
     1442
     1443
     1444;;; This returns in array units, which are from the upper-left corner
     1445(DEFUN CD-RASTER-RANGE (CD)
     1446  (DECLARE (RETURN-LIST MINX MINY MAXX MAXY))
     1447  (LOOP WITH HEIGHT = (ARRAY-DIMENSION-N 1 CD)
     1448        AND WIDTH = (ARRAY-DIMENSION-N 2 CD)
     1449        WITH MINX = WIDTH AND MINY = HEIGHT
     1450        AND MAXX = 0 AND MAXY = 0
     1451        FOR X FROM 0 BELOW WIDTH
     1452        DO (LOOP FOR Y FROM 0 BELOW HEIGHT
     1453                 WHEN (NOT (ZEROP (AREF CD Y X)))
     1454                 DO (SETQ MINX (MIN MINX X)
     1455                          MAXX (MAX MAXX (1+ X))
     1456                          MINY (MIN MINY Y)
     1457                          MAXY (MAX MAXY (1+ Y))))
     1458        FINALLY (RETURN (MIN MINX MAXX) (MIN MINY MAXY) MAXX MAXY)))
     1459
     1460;Return how many rasters are empty (all 0)
     1461;at the bottom of the character and at the top.
     1462(DEFUN CD-UNUSED-RASTER-HEIGHT (CD)
     1463  (DECLARE (RETURN-LIST BOTTOM TOP))
     1464  (LET* ((DIMS (ARRAY-DIMENSIONS CD))
     1465         BOTTOM TOP
     1466         (HEIGHT (CAR DIMS))
     1467         (WIDTH (CADR DIMS)))
     1468    (DOTIMES (I HEIGHT)
     1469      (AND (DOTIMES (J WIDTH)
     1470             (AND (NOT (ZEROP (AREF CD I J)))
     1471                  (RETURN T)))
     1472           (RETURN (SETQ TOP I))))
     1473    (DOTIMES (I HEIGHT)
     1474      (AND (DOTIMES (J WIDTH)
     1475             (AND (NOT (ZEROP (AREF CD (- HEIGHT I 1) J)))
     1476                  (RETURN T)))
     1477           (RETURN (SETQ BOTTOM I))))
     1478    (COND (TOP (VALUES BOTTOM TOP))
     1479          ;; Handle case where all data is empty.
     1480          (T (VALUES HEIGHT 0)))))
     1481
     1482;Write an AC file from a Lisp machine font.
     1483(DEFUN WRITE-FONT-INTO-AC (FONTNAME &OPTIONAL FILENAME)
     1484  (MULTIPLE-VALUE (FONTNAME FILENAME)
     1485    (GET-OUTPUT-FILENAME-AND-FONTNAME FONTNAME FILENAME "AC"))
     1486  (LET ((FD (FONT-NAME-FONT-DESCRIPTOR FONTNAME)))
     1487    (WRITE-FONT-DESCRIPTOR-INTO-AC FD FILENAME)))
     1488
     1489(DEFUN WRITE-FONT-DESCRIPTOR-INTO-AC (FD &OPTIONAL FILENAME
     1490                                         &AUX FAMILY-NAME FACE-CODE POINT-SIZE BC EC)
     1491  (SETQ FILENAME (GET-OUTPUT-FILENAME-FROM-FONT-DESCRIPTOR FD FILENAME "AC"))
     1492  (SETF (VALUES FAMILY-NAME FACE-CODE POINT-SIZE)
     1493        (PRESS:DECODE-FONT-NAME (STRING (FD-NAME FD))))
     1494  (WITH-OPEN-FILE (OUTPUT-FILE FILENAME '(:WRITE :FIXNUM))
     1495    (LET* ((FONT-LENGTH (ARRAY-ACTIVE-LENGTH FD))
     1496           UNUSED-TOP-RASTERS UNUSED-BOTTOM-RASTERS
     1497           CHAR-DATA-SIZE-TABLE (TOTAL-DATA-SIZE 0))
     1498
     1499      (AND (> FONT-LENGTH 400)
     1500           (PROGN (SETQ FONT-LENGTH 400)
     1501                  (CERROR T NIL NIL "Font contains codes above 377 which AC file cannot hold"
     1502                          )))
     1503
     1504      (SETQ UNUSED-TOP-RASTERS (MAKE-ARRAY FONT-LENGTH)
     1505            UNUSED-BOTTOM-RASTERS (MAKE-ARRAY FONT-LENGTH))
     1506
     1507      ;; Figure out range of chars to actually output.
     1508      (DOTIMES (I FONT-LENGTH)
     1509        (AND (AREF FD I) (RETURN (SETQ BC I))))
     1510      (DO ((I (1- FONT-LENGTH) (1- I)))
     1511          ((MINUSP I))
     1512        (AND (AREF FD I) (RETURN (SETQ EC I))))
     1513
     1514      ;; Precompute how much data each character is going to require.
     1515      ;; Count number of words of rasters, plus 1 word of info before them.
     1516      (SETQ CHAR-DATA-SIZE-TABLE (MAKE-ARRAY FONT-LENGTH))
     1517      (DOTIMES (CHAR-CODE FONT-LENGTH)
     1518        (LET* ((CD (AREF FD CHAR-CODE))
     1519               (DATA-SIZE 0))
     1520          (AND CD
     1521               (MULTIPLE-VALUE-BIND (TEM1 TEM2)
     1522                   (CD-UNUSED-RASTER-HEIGHT CD)
     1523                 (SETF (AREF UNUSED-BOTTOM-RASTERS CHAR-CODE) TEM1)
     1524                 (SETF (AREF UNUSED-TOP-RASTERS CHAR-CODE) TEM2)
     1525                 (SETQ DATA-SIZE (1+ (* (// (+ (- (ARRAY-DIMENSION-N 1 CD) TEM1 TEM2) 17) 20)
     1526                                        (ARRAY-DIMENSION-N 2 CD))))))
     1527          (SETQ TOTAL-DATA-SIZE (+ TOTAL-DATA-SIZE DATA-SIZE))
     1528          (SETF (AREF CHAR-DATA-SIZE-TABLE CHAR-CODE) DATA-SIZE)))
     1529      (SETQ TOTAL-DATA-SIZE (+ TOTAL-DATA-SIZE (* 10. (- EC BC -1))))
     1530      ;; Index entry type 1, 12. words long.
     1531      (FUNCALL OUTPUT-FILE ':TYO (DPB 1 1404 12.))
     1532      ;; Family code - always 1, since we only write one family.
     1533      (FUNCALL OUTPUT-FILE ':TYO 1)
     1534      ;; Write the family name now.
     1535      (DO ((I 0 (1+ I))
     1536           (LEN (STRING-LENGTH FAMILY-NAME))
     1537           (HIGH-BYTE (STRING-LENGTH FAMILY-NAME)))
     1538          ((= I 19.))
     1539        (LET ((CH (IF (< I LEN)
     1540                      (AREF FAMILY-NAME I)
     1541                      0)))
     1542          (IF HIGH-BYTE
     1543              (PROGN (FUNCALL OUTPUT-FILE ':TYO
     1544                              (DPB HIGH-BYTE 1010 CH))
     1545                     (SETQ HIGH-BYTE NIL))
     1546              (SETQ HIGH-BYTE CH))))
     1547      ;; Now write the index entry for the data segment.
     1548      ;; Type 3, 11. words long.
     1549      (FUNCALL OUTPUT-FILE ':TYO (DPB 3 1404 11.))
     1550      ;; Now family code and face code.
     1551      (FUNCALL OUTPUT-FILE ':TYO (DPB 1 1010 (PRESS:ENCODE-PRESS-FACE FACE-CODE)))
     1552      ;; Now range of characters actually existing in the font.
     1553      (FUNCALL OUTPUT-FILE ':TYO (DPB BC 1010 EC))
     1554      ;; Now size of font.
     1555      (FUNCALL OUTPUT-FILE ':TYO (// (+ (* POINT-SIZE 2540.) 36.) 72.))
     1556      ;; Rotation is 0.
     1557      (FUNCALL OUTPUT-FILE ':TYO 0)
     1558      ;; Position in file of start of data (2 words).
     1559      (FUNCALL OUTPUT-FILE ':TYO 0)
     1560      (FUNCALL OUTPUT-FILE ':TYO 24.)
     1561      ;; Number of words of data.
     1562      (FUNCALL OUTPUT-FILE ':TYO (LDB 2020 TOTAL-DATA-SIZE))
     1563      (FUNCALL OUTPUT-FILE ':TYO (LDB 0020 TOTAL-DATA-SIZE))
     1564      ;; Resolutions
     1565      (FUNCALL OUTPUT-FILE ':TYO (FD-HORIZ-RESOLUTION FD))
     1566      (FUNCALL OUTPUT-FILE ':TYO (FD-VERT-RESOLUTION FD))
     1567      ;; Index entry type 0, end of index.
     1568      (FUNCALL OUTPUT-FILE ':TYO 1)
     1569     
     1570      ;; Output descriptions of the characters in the font.
     1571      (DO ((CHAR-CODE BC (1+ CHAR-CODE)))
     1572          ((> CHAR-CODE EC))
     1573        (LET ((CD (AREF FD CHAR-CODE)))
     1574          (COND ((NULL CD)
     1575                 (FUNCALL OUTPUT-FILE ':TYO 0)
     1576                 (FUNCALL OUTPUT-FILE ':TYO 0)
     1577                 (FUNCALL OUTPUT-FILE ':TYO 0)
     1578                 (FUNCALL OUTPUT-FILE ':TYO 0)
     1579                 (FUNCALL OUTPUT-FILE ':TYO 0)
     1580                 (FUNCALL OUTPUT-FILE ':TYO 0)
     1581                 (FUNCALL OUTPUT-FILE ':TYO 0)
     1582                 (FUNCALL OUTPUT-FILE ':TYO -1))
     1583                (T
     1584                 (FUNCALL OUTPUT-FILE ':TYO (FIX (CD-CHAR-WIDTH CD)))
     1585                 (FUNCALL OUTPUT-FILE ':TYO
     1586                          (FIX (* 65536. (- (CD-CHAR-WIDTH CD) (FIX (CD-CHAR-WIDTH CD))))))
     1587                 (FUNCALL OUTPUT-FILE ':TYO (FIX (CD-CHAR-VERT-WIDTH CD)))
     1588                 (FUNCALL OUTPUT-FILE ':TYO
     1589                          (FIX (* 65536. (- (CD-CHAR-VERT-WIDTH CD)
     1590                                            (FIX (CD-CHAR-VERT-WIDTH CD))))))
     1591                 (FUNCALL OUTPUT-FILE ':TYO (- (CD-CHAR-LEFT-KERN CD)))
     1592                 (FUNCALL OUTPUT-FILE ':TYO (+ (- (FD-BASELINE FD)
     1593                                                  (FD-LINE-SPACING FD))
     1594                                               (AREF UNUSED-BOTTOM-RASTERS CHAR-CODE)))
     1595                 (FUNCALL OUTPUT-FILE ':TYO (CADR (ARRAY-DIMENSIONS CD)))
     1596                 (FUNCALL OUTPUT-FILE ':TYO (- (CAR (ARRAY-DIMENSIONS CD))
     1597                                               (AREF UNUSED-BOTTOM-RASTERS CHAR-CODE)
     1598                                               (AREF UNUSED-TOP-RASTERS CHAR-CODE)))))))
     1599      ;; Output offsets to data for each character.
     1600      (LET* ((CURRENT-POS (+ 24. (* 8 (- EC BC -1))))
     1601             (EXPECTED-DATA-START
     1602               (+ CURRENT-POS (* 2 (- EC BC -1)))))
     1603        (DO ((CHAR-CODE BC (1+ CHAR-CODE)))
     1604            ((> CHAR-CODE EC))
     1605          (LET ((OFFSET (- EXPECTED-DATA-START CURRENT-POS)))
     1606            (FUNCALL OUTPUT-FILE ':TYO (LDB 2020 OFFSET))
     1607            (FUNCALL OUTPUT-FILE ':TYO (LDB 0020 OFFSET)))
     1608          (SETQ EXPECTED-DATA-START
     1609                (+ EXPECTED-DATA-START
     1610                   (AREF CHAR-DATA-SIZE-TABLE CHAR-CODE)))))
     1611     
     1612      ;; Now output the rasters themselves.
     1613      (DO ((CHAR-CODE BC (1+ CHAR-CODE)))
     1614          ((> CHAR-CODE EC))
     1615        (LET* (WD
     1616               (CD (AREF FD CHAR-CODE)))
     1617          (COND (CD
     1618                 (LET* ((RASTER-WIDTH (ARRAY-DIMENSION-N 2 CD))
     1619                        (RASTER-BOTTOM-SKIP (AREF UNUSED-BOTTOM-RASTERS CHAR-CODE))
     1620                        (REAL-RASTER-HEIGHT (ARRAY-DIMENSION-N 1 CD))
     1621                        (RASTER-HEIGHT (- REAL-RASTER-HEIGHT
     1622                                          RASTER-BOTTOM-SKIP
     1623                                          (AREF UNUSED-TOP-RASTERS CHAR-CODE))))
     1624                   ;; Output redundant raster size info word.
     1625                   (FUNCALL OUTPUT-FILE ':TYO
     1626                            (DPB (// (+ RASTER-HEIGHT 17) 20)
     1627                                 1206
     1628                                 (ARRAY-DIMENSION-N 2 CD)))
     1629                   ;; Raster lines go vertically up, leftmost line first.
     1630                   (DOTIMES (HPOS RASTER-WIDTH)
     1631                     (SETQ WD 0)
     1632                     ;; Write the next vertical scan line.
     1633                     (DOTIMES (VPOS RASTER-HEIGHT)
     1634                       (SETQ WD (+ WD (LSH (AREF CD (- REAL-RASTER-HEIGHT
     1635                                                       1 VPOS RASTER-BOTTOM-SKIP)
     1636                                                 HPOS)
     1637                                           
     1638                                           (- 17 (\ VPOS 20)))))
     1639                       ;; If wd is full, output it.
     1640                       (AND (ZEROP (\ (1+ VPOS) 16.))
     1641                            (PROGN (FUNCALL OUTPUT-FILE ':TYO WD)
     1642                                   (SETQ WD 0))))
     1643                     ;; Output partially-filled word at end.
     1644                     (OR (ZEROP (\ RASTER-HEIGHT 16.))
     1645                         (FUNCALL OUTPUT-FILE ':TYO WD)))))))))
     1646    (FUNCALL OUTPUT-FILE ':CLOSE)
     1647    (FUNCALL OUTPUT-FILE ':TRUENAME)))
     1648
     1649(DEFUN READ-AST-INTO-FONT (FILENAME &OPTIONAL FONTNAME)
     1650  (MULTIPLE-VALUE (FILENAME FONTNAME)
     1651    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AST"))
     1652  (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME
     1653                                     (READ-AST-INTO-FONT-DESCRIPTOR FILENAME FONTNAME))
     1654  FONTNAME)
     1655
     1656(DEFUN READ-AST-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME &AUX FD)
     1657  (MULTIPLE-VALUE (FILENAME FONTNAME)
     1658    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AST"))
     1659  (WITH-OPEN-FILE (STREAM FILENAME '(:IN))
     1660    (SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME MAKE-ARRAY (:LENGTH 200)))
     1661    (READ-AST-DN STREAM)                        ;DISCARD KSTID
     1662    (SETF (FD-LINE-SPACING FD) (READ-AST-DN STREAM))
     1663    (SETF (FD-BASELINE FD) (READ-AST-DN STREAM))
     1664    (READ-AST-DN STREAM)                        ;COLUMN POSITION ADJUSTMENT
     1665    (SETF (FD-SPACE-WIDTH FD) 0)                ;Just in case no space character.
     1666    (SETF (FD-BLINKER-HEIGHT FD)
     1667          (FD-LINE-SPACING FD))
     1668    (SETF (FD-NAME FD) FONTNAME)
     1669    (LET (KERN CHAR-CODE RASTER-WIDTH INPUT-RASTER-WIDTH CHAR-WIDTH
     1670          CD CH (LINE-HEIGHT (FD-LINE-SPACING FD)))
     1671      (DO ()
     1672          ((NULL (READ-AST-NEXT-PAGE STREAM)))
     1673        (SETQ CHAR-CODE (READ-AST-ON STREAM))
     1674        (SETQ INPUT-RASTER-WIDTH (READ-AST-DN STREAM) RASTER-WIDTH INPUT-RASTER-WIDTH)
     1675        (SETQ CHAR-WIDTH (READ-AST-DN STREAM))
     1676        (SETQ KERN (READ-AST-DN STREAM))
     1677        (COND ((< KERN 0)                       ;FED COMPACT RASTER LOSSAGE
     1678               (SETQ RASTER-WIDTH (+ RASTER-WIDTH (ABS KERN)))
     1679               (SETQ KERN 0)))
     1680        (SETQ CD (MAKE-CHAR-DESCRIPTOR
     1681                   MAKE-ARRAY (:TYPE ART-1B :LENGTH (LIST LINE-HEIGHT RASTER-WIDTH))))
     1682        (SETF (CD-CHAR-WIDTH CD) CHAR-WIDTH)
     1683        (SETF (CD-CHAR-LEFT-KERN CD) KERN)
     1684        (FD-STORE-CD FD CD CHAR-CODE)
     1685        (AND (= CHAR-CODE #\SP)
     1686             (SETF (FD-SPACE-WIDTH FD) CHAR-WIDTH))
     1687        (DO-NAMED TOP ((VPOS 0 (1+ VPOS)))
     1688                  ((= VPOS LINE-HEIGHT))
     1689          (DO ((HCNT 0 (1+ HCNT)))
     1690              ((= HCNT INPUT-RASTER-WIDTH)
     1691               (DO ((CH)) ()
     1692                 (COND ((OR (NULL (SETQ CH (FUNCALL STREAM ':TYI)))
     1693                            (= CH #\RETURN))
     1694                        (RETURN NIL))
     1695                       ((NOT (= CH #\SPACE))
     1696                        (FERROR NIL "non space seen past raster width")))))
     1697            (SETQ CH (FUNCALL STREAM ':TYI))
     1698            (COND ((NULL CH)
     1699                   (RETURN-FROM TOP NIL))
     1700                  ((= CH #\FORM)
     1701                   (FUNCALL STREAM ':UNTYI CH)
     1702                   (RETURN-FROM TOP NIL))
     1703                  ((OR (< CH 40) (> CH 200))
     1704                   (DO () ((= CH #\RETURN)) (SETQ CH (FUNCALL STREAM ':TYI)))
     1705                   (RETURN NIL))
     1706                  ((> CH 40)
     1707                   (ASET 1 CD VPOS (+ HCNT (- RASTER-WIDTH INPUT-RASTER-WIDTH)))))))
     1708     ; (COND ((> CHAR-CODE 37) (TYO CHAR-CODE))
     1709     ;        (T (PRINC '^) (TYO (+ 100 CHAR-CODE))))
     1710        )
     1711      ;; Truncate fd to discard unused elements at the end.
     1712      (DO ((I (1- (ARRAY-LENGTH FD)) (1- I)))
     1713          ((OR (MINUSP I)
     1714               (AREF FD I))
     1715           (ADJUST-ARRAY-SIZE FD (1+ I))))
     1716      (SETF (FD-FILL-POINTER FD) (ARRAY-LENGTH FD))
     1717      ;; Set width of blinker and space fields from the space character.
     1718      (SETF (FD-BLINKER-WIDTH FD)
     1719            (FD-SPACE-WIDTH FD))
     1720      FD)))
     1721
     1722(DEFUN READ-AST-DN (STREAM)
     1723  (PROG (N CH SIGN)
     1724    (SETQ N 0 SIGN 1)
     1725    (SETQ CH (FUNCALL STREAM ':TYI))            ;LOOK FOR MINUS SIGN
     1726    (COND ((= CH #/-)
     1727           (SETQ SIGN -1))
     1728          (T (GO AA)))
     1729 A   (SETQ CH (FUNCALL STREAM ':TYI))
     1730 AA  (AND (
     1731 CH #/0) (
     1732 CH #/9)
     1733          (PROGN
     1734            (SETQ N (+ (* N 10.) (- CH #/0)))
     1735            (GO A)))
     1736 B   (AND (= CH #\RETURN) (RETURN (* N SIGN)))
     1737    (SETQ CH (FUNCALL STREAM ':TYI))
     1738    (GO B)))
     1739
     1740(DEFUN READ-AST-ON (STREAM)
     1741  (PROG (N CH)
     1742    (SETQ N 0)
     1743A   (SETQ CH (FUNCALL STREAM ':TYI))
     1744    (AND (
     1745 CH #/0) (
     1746 CH #/8)
     1747         (PROGN
     1748           (SETQ N (+ (* N 8) (- CH #/0)))
     1749           (GO A)))
     1750B   (AND (= CH #\RETURN) (RETURN N))
     1751    (SETQ CH (FUNCALL STREAM ':TYI))
     1752    (GO B)))
     1753
     1754(DEFUN READ-AST-NEXT-PAGE (STREAM)
     1755  (PROG (CH)
     1756    (COND ((NULL (SETQ CH (FUNCALL STREAM ':TYI))) (RETURN NIL))
     1757          ((= CH #\FORM)
     1758           (SETQ CH (FUNCALL STREAM ':TYI))
     1759           (FUNCALL STREAM ':UNTYI CH)
     1760           (IF (NULL CH)
     1761               (RETURN NIL)
     1762               (RETURN T)))
     1763          (T (FERROR NIL "Random char where FF expected")))))
     1764
     1765(DEFUN WRITE-FONT-INTO-AST (FONTNAME &OPTIONAL FILENAME)
     1766  (MULTIPLE-VALUE (FONTNAME FILENAME)
     1767    (GET-OUTPUT-FILENAME-AND-FONTNAME FONTNAME FILENAME "AST"))
     1768  (LET ((FD (FONT-NAME-FONT-DESCRIPTOR FONTNAME)))
     1769    (WRITE-FONT-DESCRIPTOR-INTO-AST FD FILENAME)))
     1770
     1771(DEFUN WRITE-FONT-DESCRIPTOR-INTO-AST (FD &OPTIONAL FILENAME
     1772                                          &AUX (FONT-LENGTH (ARRAY-ACTIVE-LENGTH FD)))
     1773  (SETQ FILENAME (GET-OUTPUT-FILENAME-FROM-FONT-DESCRIPTOR FD FILENAME "AST"))
     1774  (WITH-OPEN-FILE (STREAM FILENAME '(:OUT :ASCII))
     1775    (FORMAT STREAM "0 KSTID ~A"  FILENAME)
     1776    (FORMAT STREAM "~%~D HEIGHT" (FD-LINE-SPACING FD))
     1777    (FORMAT STREAM "~%~D BASE LINE" (FD-BASELINE FD))
     1778    (FORMAT STREAM "~%0 COLUMN POSITION ADJUSTMENT~%")
     1779    ;; Then write out all the characters.
     1780    (LET (CD CHAR-HEIGHT)
     1781      (DOTIMES (CHAR-CODE FONT-LENGTH)
     1782        (COND ((AND (SETQ CD (AREF FD CHAR-CODE))
     1783                      ;; Wide fonts without chars-exist-tables can have 0-width chars.
     1784                    (OR (NOT (ZEROP (ARRAY-DIMENSION-N 2 CD)))
     1785                        (NOT (ZEROP (CD-CHAR-WIDTH CD)))))
     1786               (FUNCALL STREAM ':TYO #\FORM)
     1787               (FORMAT STREAM "~O CHARACTER CODE ~A" CHAR-CODE FILENAME)
     1788               (FORMAT STREAM "~%~D RASTER WIDTH" (ARRAY-DIMENSION-N 2 CD))
     1789               (FORMAT STREAM "~%~D CHARACTER WIDTH" (CD-CHAR-WIDTH CD))
     1790               (FORMAT STREAM "~%~D LEFT KERN~%" (CD-CHAR-LEFT-KERN CD))
     1791               (SETQ CHAR-HEIGHT (ARRAY-DIMENSION-N 1 CD))
     1792               (DOTIMES (VPOS CHAR-HEIGHT)
     1793                 (DOTIMES (HPOS (ARRAY-DIMENSION-N 2 CD))
     1794                   (FUNCALL STREAM ':TYO (IF (ZEROP (AREF CD VPOS HPOS))
     1795                                             #\SPACE
     1796                                             #/*)))
     1797                 (FUNCALL STREAM ':TYO #\RETURN))))))
     1798    (FUNCALL STREAM ':CLOSE)
     1799    (FUNCALL STREAM ':TRUENAME)))
     1800
  • trunk/lisp/lmio1/fntdef.lisp

    r253 r288  
    1 ;These are the definitions for the new font hacking stuff       -*-LISP-*-
     1;These are the definitions for the new font hacking stuff       -*-Mode:LISP; Package:fed-*-
    22
    33;The elements of a FONT-DESCRIPTOR are either NIL or a CHAR-DESCRIPTOR.
    44;If NIL then this character is not defined for this font.
    55
    6 (DEFSTRUCT (FONT-DESCRIPTOR :ARRAY-LEADER :NAMED
    7                                   (:MAKE-ARRAY (NIL 'ART-Q 200)))
    8            FD-FILL-POINTER
     6(DEFSTRUCT (FONT-DESCRIPTOR :ARRAY-LEADER :NAMED)
     7           (FD-FILL-POINTER 0)
    98           FD-NAME
    109           FD-LINE-SPACING              ;Vertical distance between baselines.
     
    1514           FD-BLINKER-WIDTH             ;Width of a "blinker" in this font.
    1615           FD-SPACE-WIDTH               ;Width of a space.
    17            FD-DOUBLE-WIDTH-P)           ;T means this font is intended for display
     16           FD-DOUBLE-WIDTH-P            ;T means this font is intended for display
    1817                                        ;with twice as many pixels per unit distance
    1918                                        ;in the horizontal direction. (ESCAPE 7)
     19
     20                                        ;The rest is for saving info that
     21                                        ;comes in Xerox fonts, so we don't lose it.
     22           (FD-VERT-RESOLUTION 3840.)   ;Dots per inch, times ten.
     23           (FD-HORIZ-RESOLUTION 3840.)  ;" "
     24                                        ;Default is right for the Dover.
     25           (FD-ROTATION 0)              ;Rotation in degrees.
     26           )
    2027
    2128;A CHAR-DESCRIPTOR is a two dimensional array (with leader).
     
    2633           CD-NAME
    2734           CD-CHAR-WIDTH                ;The horizontal distance taken by this character
     35           CD-CHAR-VERT-WIDTH           ;Vertical spacing caused by this character
     36                                        ;(always 0 for the usual horizontal font).
     37                                        ;For the sake of Xerox fonts.
    2838           CD-CHAR-LEFT-KERN)           ;The distance to the left to move before placing the
    2939                                        ;character.  A left kern of -5 means the array is to
  • trunk/lisp/lmio1/press.lisp

    r255 r288  
    1 ;;; -*- Mode:Lisp; Package:Press; base:8.; ibase:8. -*-
    2 
    3 ;;;; PRESS File and DOVER software
    4 
    5 (DEFVAR PRESS-USE-EFTP NIL)     ;T => EFTP, NIL => Chaos
    6 (DEFVAR DOVER-ADDRESS 1002)     ;2#2#
    7 (DEFVAR 926-ALTO-ADDRESS 1140)  ;Alto in Moon's office
    8                                 ;CADR-6 is 1#36# as far as Xerox is concerned
    9 
    10 (EVAL-WHEN (EVAL COMPILE LOAD)
    11      (OR (FBOUNDP 'CHAOS:GET-PUP) (LOAD "AI;LMIO1;EFTP QFASL")))
     1;;; -*- Mode:Lisp; Package:Press; Base:8 -*-
     2;;; PRESS File and DOVER software
     3;;; ** (c) Copyright 1981 Massachusetts Institute of Technology **
     4
     5(DEFVAR PRESS-SPECIAL-VARIABLES NIL)
     6
     7(DEFMACRO DEFINE-PRESS-VARIABLE (NAME &OPTIONAL FORM (DEFVAR-P T))
     8  `(SI:DEFINE-SPECIAL-VARIABLE ,NAME ,FORM PRESS-SPECIAL-VARIABLES ,DEFVAR-P))
     9
     10(DEFMACRO BIND-PRESS-VARIABLES (&BODY BODY)
     11  `(PROGW PRESS-SPECIAL-VARIABLES
     12     (UNWIND-PROTECT
     13       (PROGN . ,BODY)
     14       (DEALLOCATE-RESOURCE 'PRESS-PAGE-ENTITY-BUFFER PRESS-PAGE-ENTITY-BUFFER))))
     15
     16(DEFINE-PRESS-VARIABLE PRESS-USE-EFTP NIL)      ;T => EFTP, NIL => Chaos
     17(DEFVAR DOVER-ADDRESS 1002)                     ;2#2#
    1218
    1319;Don't get too strung out by the little frob at the end of the message.
    1420(DEFUN PRINT-DOVER-STATUS ()
    15   (DO ((N-RETRIES 10. (1- N-RETRIES))
    16        (PORT (CHAOS:GET-PORT-NUMBER))
    17        (PUP))
    18       ((ZEROP N-RETRIES)
    19        (FORMAT T "~&Dover is not responding (may be printing).~%"))
    20     (CHAOS:TRANSMIT-PUP (CHAOS:GET-PUP DOVER-ADDRESS 21 PORT 200 0) 0)
    21     (COND ((SETQ PUP (CHAOS:RECEIVE-PUP PORT))
    22            (COND ((= (CHAOS:PUP-TYPE PUP) 201)
    23                   (FORMAT T "~&Dover status: ~[~;Spooler shut off.~;Spooler available.~;Spooler busy.~]  ~A~%"
    24                             (AREF PUP 22.)
    25                             (CHAOS:PUP-STRING PUP 2))
    26                   (CHAOS:FREE-INT-PKT PUP)
    27                   (RETURN T))
    28                  (T (CHAOS:RECEIVED-RANDOM-PUP PUP)))))))
     21  (LET ((CONN (CHAOS:OPEN-FOREIGN-CONNECTION DOVER-ADDRESS 21)))
     22    (UNWIND-PROTECT
     23      (DO ((N-RETRIES 10. (1- N-RETRIES))
     24           (PUP))
     25          ((ZEROP N-RETRIES)
     26           (FORMAT T "~&Dover is not responding (may be printing).~%"))
     27        (CHAOS:TRANSMIT-PUP CONN (CHAOS:GET-PUP CONN 200 0) 0)
     28        (COND ((SETQ PUP (CHAOS:RECEIVE-PUP CONN))
     29               (COND ((= (CHAOS:PUP-TYPE PUP) 201)
     30                      (FORMAT T "~&Dover status: ~[~;Spooler shut off.~;Spooler available.~
     31                                 ~;Spooler busy.~]  ~A~%"
     32                              (CHAOS:PUP-WORD PUP 0)
     33                              (CHAOS:PUP-STRING PUP 2))
     34                      (CHAOS:RETURN-PKT PUP)
     35                      (RETURN T))
     36                     (T (CHAOS:RECEIVED-RANDOM-PUP PUP))))))
     37      (CHAOS:REMOVE-CONN CONN))))
     38
     39(DEFUN PRINT-DOVER-QUEUE ()
     40  ;; Avoid opening a new file job to MC if logged in to AI.
     41  (FS:VIEWF (IF (EQ FS:USER-LOGIN-MACHINE
     42                    (SI:PARSE-HOST "AI"))
     43                "AI: DVR: FOO; .FILE. (DIR)"
     44                "MC: DVR: FOO; .FILE. (DIR)")))
    2945
    3046
     
    3349;;; Later this might be made into a more stream-like thing (as a "resource")
    3450
    35 (DEFVAR PRESS-EFTP-STREAM)                      ;EFTP connection we send through
    36 (DEFVAR PRESS-N-CHARS)                          ;Number of characters sent this part
    37 (DEFVAR PRESS-CURRENT-RECORD-NUMBER)            ;Record number within file
    38 (DEFVAR PRESS-X)                                ;X position computed as characters sent
    39 (DEFVAR PRESS-Y)                                ;Y ..
    40 (DEFVAR PRESS-PAGE-NUMBER)                      ;Serial number of page
    41 (DEFVAR PRESS-END-PAGE-HOOK   NIL)              ;If non-NIL, function to call
    42 (DEFVAR PRESS-PENDING-CHARS)                    ;Number of chars output but not yet known
     51(DEFINE-PRESS-VARIABLE PRESS-INTERPRET-XGP-ESCAPE NIL)  ;177 is special character in input
     52(DEFINE-PRESS-VARIABLE PRESS-EFTP-STREAM NIL)   ;EFTP connection we send through
     53(DEFINE-PRESS-VARIABLE PRESS-N-CHARS)           ;Number of characters sent this part
     54(DEFINE-PRESS-VARIABLE PRESS-CURRENT-RECORD-NUMBER 0)   ;Record number within file
     55(DEFINE-PRESS-VARIABLE PRESS-X)                 ;X position computed as characters sent
     56(DEFINE-PRESS-VARIABLE PRESS-Y)                 ;Y ..
     57(DEFINE-PRESS-VARIABLE PRESS-BASELINE-Y)        ;Baseline Y, usually the same
     58(DEFINE-PRESS-VARIABLE PRESS-INTERCHAR-SPACING NIL)     ;Between all chars if non-NIL
     59(DEFINE-PRESS-VARIABLE PRESS-INTERLINE-SPACING NIL)     ;Between all lines if non-NIL
     60(DEFINE-PRESS-VARIABLE PRESS-PAGE-NUMBER 1)     ;Serial number of page
     61(DEFINE-PRESS-VARIABLE PRESS-END-PAGE-HOOK NIL) ;If non-NIL, function to call
     62(DEFINE-PRESS-VARIABLE PRESS-PENDING-CHARS)     ;Number of chars output but not yet known
    4363                                                ;about at the "entity" level
    4464
    45 (DEFVAR PRESS-DATA-LIST-START)                  ;Value of PRESS-N-CHARS at start of entity
    46 (DEFVAR PRESS-ENTITY-LIST-START)                ;Value of (size of entity buffer) at ..
     65(DEFINE-PRESS-VARIABLE PRESS-DATA-LIST-START)   ;Value of PRESS-N-CHARS at start of entity
     66(DEFINE-PRESS-VARIABLE PRESS-ENTITY-LIST-START) ;Value of (size of entity buffer) at ..
    4767
    4868(DEFVAR PRESS-PAGE-ENTITY-BUFFER-EXTENSION-SIZE 4000.)
    49 (DEFVAR PRESS-PAGE-ENTITY-BUFFER
    50         (MAKE-ARRAY NIL 'ART-8B PRESS-PAGE-ENTITY-BUFFER-EXTENSION-SIZE NIL '(0)))
     69(DEFRESOURCE PRESS-PAGE-ENTITY-BUFFER ()
     70  :CONSTRUCTOR (MAKE-ARRAY PRESS-PAGE-ENTITY-BUFFER-EXTENSION-SIZE
     71                           ':TYPE 'ART-8B
     72                           ':LEADER-LIST '(0)))
     73(DEFINE-PRESS-VARIABLE PRESS-PAGE-ENTITY-BUFFER (ALLOCATE-RESOURCE 'PRESS-PAGE-ENTITY-BUFFER))
    5174                                                ;This holds the "entity" portion of the
    5275                                                ;current page
    5376
    54 (DEFVAR PRESS-PART-LIST) ;List of elements (part-type record-number n-records n-padding-words)
    55 (DEFVAR PRESS-FONT-LIST) ;List of elements (family-name face-name point-size rotation
    56                          ;                  width height width-table)
    57 (DEFVAR PRESS-CURRENT-FONT NIL)                 ;Element for selected font
    58 
    59 (DEFVAR DOVER-X0 2000.)                         ;2 cm left margin
    60 (DEFVAR DOVER-Y0 (FIX (* 9.8 2540.)))           ;Where the page number goes
    61 (DEFVAR DOVER-Y1 (FIX (* 9.5 2540.)))           ;Where the text starts
    62 (DEFVAR DOVER-Y2 (FIX (* 0.5 2540.)))           ;Margin at the bottom of the page
    63 (DEFVAR LINE-WIDTH 25.)                         ;Line width .01 inch
     77(DEFINE-PRESS-VARIABLE PRESS-PART-LIST NIL)     ;List of elements (part-type record-number
     78                                                ;                  n-records n-padding-words)
     79(DEFINE-PRESS-VARIABLE PRESS-FONT-LIST NIL)     ;List of elements (family-name face-name
     80                                                ;                  point-size rotation
     81                                                ;                  width height width-table)
     82(DEFINE-PRESS-VARIABLE PRESS-CURRENT-FONT NIL)  ;Element for selected font
     83
     84(DEFINE-PRESS-VARIABLE DOVER-X0 2000.)          ;2 cm left margin
     85(DEFINE-PRESS-VARIABLE DOVER-Y0 (FIX (* 9.8 2540.)))    ;Where the page number goes
     86(DEFINE-PRESS-VARIABLE DOVER-Y1 (FIX (* 9.5 2540.)))    ;Where the text starts
     87(DEFINE-PRESS-VARIABLE DOVER-Y2 (FIX (* 0.5 2540.)))    ;Margin at the bottom of the page
     88(DEFINE-PRESS-VARIABLE LINE-WIDTH 25.)          ;Line width .01 inch
    6489;(DEFVAR DIAGONAL-LINE-WIDTH 18.)               ;Make darkness come out even
    6590;This provides nice thin lines, for thinner lines you might want 2 instead of 4
     
    79104;       226-232    The 1.-bit box
    80105;       240        The 0-bit box (or isolated point).
     106
     107(DEFINE-PRESS-VARIABLE PRESS-XGP-UNDERLINE-START-X)
     108(DEFINE-PRESS-VARIABLE PRESS-XGP-FONT-LIST NIL)
    81109
    82110
     
    200228
    201229(DEFUN PRESS-START-FILE (&OPTIONAL (HOST-ADDRESS DOVER-ADDRESS))
    202   (FS:FILE-BIND-DEFAULTS
    203     (OR (FBOUNDP 'LOAD-FONT-WIDTHS) (LOAD "AI:LMIO1;RFONTW QFASL"))
    204     (OR (BOUNDP 'FONT-WIDTH-DATA) (LOAD-FONT-WIDTHS))
    205     (SETQ PRESS-EFTP-STREAM
    206           (IF (NUMBERP HOST-ADDRESS)
    207               (IF PRESS-USE-EFTP (CHAOS:MAKE-EFTP-WRITE-STREAM HOST-ADDRESS T)
    208                   (LET ((CONN (CHAOS:CONNECT 426 "DOVER")))
    209                     (AND (STRINGP CONN)
    210                          (FERROR NIL
    211                                  "~A - cannot connect to DOVER server at AI-CHAOS-11" CONN))
    212                     (CHAOS:STREAM CONN)))
    213               (OPEN (SI:FILE-PARSE-NAME
    214                       HOST-ADDRESS NIL
    215                       (SI:FILE-PARSE-NAME (FORMAT NIL "MC:.DOVR.;~A >" USER-ID)))
    216                     '(:WRITE :FIXNUM :BYTE-SIZE 8)))
    217           PRESS-CURRENT-RECORD-NUMBER 0
    218           PRESS-PART-LIST NIL
    219           PRESS-FONT-LIST NIL                   ;this is a crock ***
    220           PRESS-PAGE-NUMBER 1
    221           )))
    222 
     230  (OR (BOUNDP 'FONT-WIDTH-DATA)
     231      (LOAD-FONT-WIDTHS "SYS: PRESS-FONTS; FONTS WIDTHS >"))
     232  (SETQ PRESS-EFTP-STREAM (PRESS-OPEN-EFTP-STREAM HOST-ADDRESS DOVER-ADDRESS)))
     233
     234(DEFUN PRESS-OPEN-EFTP-STREAM (HOST-ADDRESS DOVER-ADDRESS)
     235  (IF (NUMBERP HOST-ADDRESS)
     236      (IF PRESS-USE-EFTP (CHAOS:MAKE-EFTP-WRITE-STREAM HOST-ADDRESS T)
     237          (LET ((CONN (CHAOS:CONNECT "AI-CHAOS-11" "DOVER")))
     238            (AND (STRINGP CONN)
     239                 (FERROR NIL
     240                         "~A - cannot connect to DOVER server at AI-CHAOS-11" CONN))
     241            (CHAOS:STREAM CONN)))
     242      (OPEN HOST-ADDRESS '(:WRITE :FIXNUM :BYTE-SIZE 8))))
    223243
    224244
     
    278298  (FUNCALL PRESS-EFTP-STREAM ':STRING-OUT PRESS-PAGE-ENTITY-BUFFER)
    279299  (PRESS-FINISH-PART (ARRAY-LEADER PRESS-PAGE-ENTITY-BUFFER 0) 1)
    280   ;; Except for :CLOSE itself this is superfluous except
    281   ;; when going through the AI-CHAOS-11 dover server
    282   (AND (MEMQ ':EOF (FUNCALL PRESS-EFTP-STREAM ':WHICH-OPERATIONS))
    283        (FUNCALL PRESS-EFTP-STREAM ':EOF))
    284   (FUNCALL PRESS-EFTP-STREAM ':CLOSE))
     300  (FUNCALL PRESS-EFTP-STREAM ':CLOSE)
     301  (FUNCALL PRESS-EFTP-STREAM ':SEND-IF-HANDLES ':TRUENAME))
    285302
    286303
     
    354371;Finish the current entity.  You can start another if you like.
    355372(DEFUN PRESS-CLOSE-ENTITY (&OPTIONAL (X-OFF DOVER-X0) (Y-OFF DOVER-Y2)
    356                                      (WIDTH (*  8. 2540.)) (HEIGHT (* 11. 2540.)))
     373                                     (WIDTH (*  85. 254.)) (HEIGHT (* 11. 2540.)))
    357374  (PRESS-PUT-PENDING-CHARS)
    358375  ;; Pad entity to word boundary with NOP
     
    432449                                      (THIRD PRESS-CURRENT-FONT)
    433450                                      (SECOND PRESS-CURRENT-FONT))
    434                (SETQ PRESS-X (+ WIDTH PRESS-X)))))
     451               (SETQ PRESS-X (+ WIDTH PRESS-X))))
     452         (AND PRESS-INTERCHAR-SPACING
     453              (PRESS-SET-CURSOR (+ PRESS-X PRESS-INTERCHAR-SPACING) PRESS-Y)))
    435454        ((= CHAR #\TAB)
    436455         ;; The bounding box seems to be wedged, it's not the same as the character
     
    439458           (PRESS-SET-CURSOR (* (1+ (// PRESS-X TAB-WIDTH)) TAB-WIDTH) PRESS-Y)))
    440459        ((= CHAR #\CR)
    441          (LET ((Y (- PRESS-Y (SIXTH PRESS-CURRENT-FONT))))
     460         (LET ((Y (- PRESS-Y (OR PRESS-INTERLINE-SPACING (SIXTH PRESS-CURRENT-FONT)))))
    442461           (IF (MINUSP Y) (PRESS-CHAR #\FORM)
    443                (PRESS-SET-CURSOR 0 Y))))
     462               (PRESS-SET-CURSOR 0 Y)))
     463         (SETQ PRESS-BASELINE-Y PRESS-Y
     464               PRESS-INTERCHAR-SPACING NIL))
    444465        ((= CHAR #\FORM)
    445466         (PRESS-END-PAGE)
    446          (PRESS-START-PAGE)))
     467         (PRESS-START-PAGE)
     468         (SETQ PRESS-INTERCHAR-SPACING NIL)))
    447469  NIL)
    448470
     
    463485;Add a font to the font set and return its font number
    464486(DEFUN PRESS-DEFINE-FONT (FAMILY-NAME FACE-NAME POINT-SIZE ROTATION)
    465   (LET ((WIDTH (GET-FONT-WIDTH-AND-HEIGHT FAMILY-NAME FACE-NAME POINT-SIZE))
    466         HEIGHT WIDTH-ARRAY FONT-DESC FONT-NUMBER)
    467     (SETQ HEIGHT (CADR WIDTH) WIDTH (CAR WIDTH))        ;Bounding box for font
    468     (SETQ WIDTH-ARRAY (GET-FONT-WIDTH-DATA FAMILY-NAME FACE-NAME POINT-SIZE))
    469     (SETQ FONT-DESC (LIST FAMILY-NAME FACE-NAME POINT-SIZE ROTATION
    470                           WIDTH HEIGHT WIDTH-ARRAY))
    471     (OR (MEMBER FONT-DESC PRESS-FONT-LIST)
    472         (SETQ PRESS-FONT-LIST (NCONC PRESS-FONT-LIST (NCONS FONT-DESC))))
    473     (SETQ FONT-NUMBER (FIND-POSITION-IN-LIST-EQUAL FONT-DESC PRESS-FONT-LIST))
    474     (AND (
     487  (OR (PRESS-LOOKUP-FONT FAMILY-NAME FACE-NAME POINT-SIZE ROTATION)
     488      (LET ((WIDTH (GET-FONT-WIDTH-AND-HEIGHT FAMILY-NAME FACE-NAME POINT-SIZE))
     489            HEIGHT WIDTH-ARRAY FONT-DESC FONT-NUMBER)
     490        (SETQ HEIGHT (CADR WIDTH) WIDTH (CAR WIDTH))    ;Bounding box for font
     491        (SETQ WIDTH-ARRAY (GET-FONT-WIDTH-DATA FAMILY-NAME FACE-NAME POINT-SIZE))
     492        (SETQ FONT-DESC (LIST FAMILY-NAME FACE-NAME POINT-SIZE ROTATION
     493                              WIDTH HEIGHT WIDTH-ARRAY))
     494        (SETQ PRESS-FONT-LIST (NCONC PRESS-FONT-LIST (NCONS FONT-DESC)))
     495        (SETQ FONT-NUMBER (1- (LENGTH PRESS-FONT-LIST)))
     496        (AND (
    475497 FONT-NUMBER 16.) (FERROR NIL "Maximum of 16 fonts allowed."))
    476     FONT-NUMBER))
     498        FONT-NUMBER)))
    477499
    478500;Similar to above, but works when there is no Fonts Widths data.  The
     
    481503;Second value is T if font not found in Fonts Widths.
    482504(DEFUN PRESS-DEFINE-FONT-FAKE (FAMILY-NAME FACE-NAME POINT-SIZE ROTATION)
    483   (IF (ERRSET (FIND-FONT-DATA FAMILY-NAME FACE-NAME POINT-SIZE) NIL)
    484       (PRESS-DEFINE-FONT FAMILY-NAME FACE-NAME POINT-SIZE ROTATION)
    485       (LET ((WIDTH 633.) (HEIGHT 698.) WIDTH-ARRAY FONT-DESC FONT-NUMBER)
    486         (SETQ WIDTH-ARRAY (MAKE-ARRAY NIL 'ART-16B 400))
    487         (FILLARRAY WIDTH-ARRAY '(633.))
    488         (SETQ FONT-DESC (LIST FAMILY-NAME FACE-NAME POINT-SIZE ROTATION
    489                               WIDTH HEIGHT WIDTH-ARRAY))
    490         (OR (MEMBER FONT-DESC PRESS-FONT-LIST)
    491             (SETQ PRESS-FONT-LIST (NCONC PRESS-FONT-LIST (NCONS FONT-DESC))))
    492         (SETQ FONT-NUMBER (FIND-POSITION-IN-LIST-EQUAL FONT-DESC PRESS-FONT-LIST))
    493         (AND (
     505  (OR (PRESS-LOOKUP-FONT FAMILY-NAME FACE-NAME POINT-SIZE ROTATION)
     506      (IF (ERRSET (FIND-FONT-DATA FAMILY-NAME FACE-NAME POINT-SIZE) NIL)
     507          (PRESS-DEFINE-FONT FAMILY-NAME FACE-NAME POINT-SIZE ROTATION)
     508          (LET ((WIDTH 633.) (HEIGHT 698.) WIDTH-ARRAY FONT-DESC FONT-NUMBER)
     509            (SETQ WIDTH-ARRAY (MAKE-ARRAY NIL 'ART-16B 400))
     510            (FILLARRAY WIDTH-ARRAY '(633.))
     511            (SETQ FONT-DESC (LIST FAMILY-NAME FACE-NAME POINT-SIZE ROTATION
     512                                  WIDTH HEIGHT WIDTH-ARRAY))
     513            (SETQ PRESS-FONT-LIST (NCONC PRESS-FONT-LIST (NCONS FONT-DESC)))
     514            (SETQ FONT-NUMBER (1- (LENGTH PRESS-FONT-LIST)))
     515            (AND (
    494516 FONT-NUMBER 16.) (FERROR NIL "Maximum of 16 fonts allowed."))
    495         (PROG () (RETURN FONT-NUMBER T)))))
     517            (PROG () (RETURN FONT-NUMBER T))))))
     518
     519;Find position of font in PRESS-FONT-LIST
     520(DEFUN PRESS-LOOKUP-FONT (FAMILY FACE POINT-SIZE ROTATION)
     521  (DO ((L PRESS-FONT-LIST (CDR L))
     522       (I 0 (1+ I)))
     523      ((NULL L))
     524    (AND (EQUAL FAMILY (CAAR L))
     525         (EQUAL FACE (SECOND (CAR L)))
     526         (EQUAL POINT-SIZE (THIRD (CAR L)))
     527         (EQUAL ROTATION (FOURTH (CAR L)))
     528         (RETURN I))))
    496529
    497530;Select a font, by number
     
    527560
    528561(DEFUN PRESS-ENTITY-BCPL-STRING (STRING NBYTES &AUX REAL-LENGTH)
     562  (SETQ STRING (STRING STRING))
    529563  (PRESS-ENTITY-BYTE (SETQ REAL-LENGTH (MIN (STRING-LENGTH STRING) (1- NBYTES))))
    530564  (DOTIMES (I REAL-LENGTH)
     
    535569
    536570
     571(DEFVAR PRESS-LINE-USE-SPECIAL-OPCODE NIL)
    537572(DEFVAR NEWVEC-SLOPE-TABLE)
    538573(DEFVAR NEWVEC-DX-TABLE)
     
    568603  (PRESS-PUT-PENDING-CHARS)
    569604  (PRESS-MAYBE-NEW-ENTITY)                      ;This should make DPLT work better
    570   (COND ((= X0 X1)                              ;Vertical line
     605  (COND (PRESS-LINE-USE-SPECIAL-OPCODE
     606         (PRESS-SET-CURSOR X0 Y0)
     607         (PRESS-ENTITY-BYTE 201)
     608         (PRESS-ENTITY-WORD X1)
     609         (PRESS-ENTITY-WORD Y1))         
     610        ((= X0 X1)                              ;Vertical line
    571611         (PRESS-SET-CURSOR (- X0 (// LINE-WIDTH 2)) (MIN Y0 Y1))        ;Lower left corner
    572612         (PRESS-SHOW-RECT LINE-WIDTH DY))
     
    685725;;;; Print a file
    686726
    687 (DEFUN PRINT-FILE (FILE-NAME &OPTIONAL (FONT-NAME "TIMESROMAN")
     727(DEFUN PRINT-PRESS-FILE (FILE-NAME &REST OPTIONS)
     728  (WITH-OPEN-FILE (INPUT-STREAM FILE-NAME)
     729    (WITH-OPEN-STREAM (OUTPUT-STREAM (BIND-PRESS-VARIABLES
     730                                       (MULTIPLE-VALUE-BIND (NIL NIL NIL NIL NIL
     731                                                             HOST-ADDRESS)
     732                                           (PRESS-DECODE-OPTIONS OPTIONS)
     733                                         (PRESS-OPEN-EFTP-STREAM HOST-ADDRESS))))
     734      (STREAM-COPY-UNTIL-EOF INPUT-STREAM OUTPUT-STREAM)
     735      (CLOSE OUTPUT-STREAM)
     736      (FUNCALL OUTPUT-STREAM ':SEND-IF-HANDLES ':TRUENAME))))
     737
     738(DEFUN PRINT-FILE (FILE-NAME &REST OPTIONS)
     739  (WITH-OPEN-FILE (STREAM FILE-NAME '(:READ))
     740    (LEXPR-FUNCALL #'PRINT-FROM-STREAM
     741                   STREAM (FUNCALL STREAM ':TRUENAME) OPTIONS)))
     742
     743(DEFUN SPOOL-FILE (FILE-NAME &REST OPTIONS)
     744  (WITH-OPEN-FILE (STREAM FILE-NAME '(:READ))
     745    (LEXPR-FUNCALL #'PRINT-FROM-STREAM
     746                   STREAM (FUNCALL STREAM ':TRUENAME) ':SPOOL T OPTIONS)))
     747
     748(DEFUN PRINT-FROM-STREAM (INPUT-STREAM FILE-NAME &REST OPTIONS
     749                          &AUX CREATION-DATE FONT-NAME FACE-NAME FONT-SIZE PAGE-HEADINGS
     750                               N-COPIES HOST-ADDRESS)
     751  (DECLARE (SPECIAL FILE-NAME CREATION-DATE))
     752  (BIND-PRESS-VARIABLES
     753    (MULTIPLE-VALUE (FONT-NAME FACE-NAME FONT-SIZE PAGE-HEADINGS N-COPIES HOST-ADDRESS)
     754      (PRESS-DECODE-OPTIONS OPTIONS))
     755    (IF (MEMQ ':CREATION-DATE (FUNCALL INPUT-STREAM ':WHICH-OPERATIONS))
     756        (SETQ CREATION-DATE (FUNCALL INPUT-STREAM ':CREATION-DATE))
     757        (SETQ CREATION-DATE (TIME:GET-UNIVERSAL-TIME)))
     758    (SETQ CREATION-DATE (TIME:PRINT-UNIVERSAL-TIME CREATION-DATE NIL))
     759    (IF PAGE-HEADINGS
     760        (SETQ PRESS-END-PAGE-HOOK
     761              #'(LAMBDA ()
     762                  (FORMAT T "~D " PRESS-PAGE-NUMBER)
     763                  (PRESS-SET-CURSOR 0 DOVER-Y0)
     764                  (PRESS-STRING (FORMAT NIL "~A~10X~A" FILE-NAME CREATION-DATE))
     765                  (PRESS-SET-CURSOR 15000. DOVER-Y0)
     766                  (PRESS-STRING (FORMAT NIL "Page ~D" PRESS-PAGE-NUMBER))))
     767        (SETQ PRESS-END-PAGE-HOOK
     768              #'(LAMBDA () (FORMAT T "~D " PRESS-PAGE-NUMBER))))
     769    (FORMAT T "~&~A:  " FILE-NAME)
     770    (UNWIND-PROTECT
     771      (PROGN (PRESS-START-FILE HOST-ADDRESS)
     772             (AND PRESS-INTERPRET-XGP-ESCAPE
     773                 (PRESS-XGP-HEADER-PAGE INPUT-STREAM))
     774             (PRESS-START-PAGE)
     775             (PRESS-SELECT-FONT (IF PRESS-INTERPRET-XGP-ESCAPE 0
     776                                    (PRESS-DEFINE-FONT FONT-NAME FACE-NAME FONT-SIZE 0)))
     777             (DO ((CH))
     778                 ((NULL (SETQ CH (FUNCALL INPUT-STREAM ':TYI))))
     779               (IF (AND PRESS-INTERPRET-XGP-ESCAPE (= CH 177))
     780                   (PRESS-XGP-ESCAPE INPUT-STREAM)
     781                   (PRESS-CHAR CH)))
     782             (PRESS-END-PAGE)
     783             (PRESS-END-FILE FILE-NAME CREATION-DATE N-COPIES
     784                             (COND ((AND FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST
     785                                         (NOT (EQUAL FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST
     786                                                     "")))
     787                                    (FORMAT NIL "~A (~A)" USER-ID
     788                                            FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST))
     789                                   (T USER-ID))))
     790      (AND PRESS-EFTP-STREAM
     791           (NOT (STRINGP PRESS-EFTP-STREAM))
     792           (FUNCALL PRESS-EFTP-STREAM ':CLOSE ':ABORT)))))
     793
     794(DEFUN PRESS-DECODE-OPTIONS (OPTIONS &AUX (FONT-NAME "LPT")
    688795                             (FACE-NAME "")
    689                              (FONT-SIZE 10.)
     796                             (FONT-SIZE 8)
    690797                             (PAGE-HEADINGS T)
    691798                             (N-COPIES 1)
    692                              (SEND-TO-MOONS-ALTO-P NIL)
    693                              (HOST-ADDRESS DOVER-ADDRESS)
    694                              &AUX INPUT-STREAM (PRESS-USE-EFTP PRESS-USE-EFTP))
    695   (AND SEND-TO-MOONS-ALTO-P (SETQ PRESS-USE-EFTP T))
    696   (UNWIND-PROTECT
    697     (LOCAL-DECLARE ((SPECIAL FILE-NAME CREATION-DATE))
    698       (SETQ INPUT-STREAM (OPEN FILE-NAME ':READ))
    699       (LET ((FILE-NAME (FUNCALL INPUT-STREAM ':GET ':UNIQUE-ID))
    700             (CREATION-DATE (FORMAT NIL "~A ~A" (FUNCALL INPUT-STREAM ':GET ':CREATION-DATE)
    701                                    (FUNCALL INPUT-STREAM ':GET ':CREATION-TIME)))
    702             (PRESS-END-PAGE-HOOK
    703               (IF PAGE-HEADINGS
    704                   #'(LAMBDA ()
    705                       (FORMAT T " page ~D " PRESS-PAGE-NUMBER)
    706                       (PRESS-SET-CURSOR 0 DOVER-Y0)
    707                       (PRESS-STRING (FORMAT NIL "~A~10X~A" FILE-NAME CREATION-DATE))
    708                       (PRESS-SET-CURSOR 15000. DOVER-Y0)
    709                       (PRESS-STRING (FORMAT NIL "Page ~D" PRESS-PAGE-NUMBER)))
    710                   #'(LAMBDA ()
    711                       (FORMAT T " page ~D " PRESS-PAGE-NUMBER)))))
    712         (OR SEND-TO-MOONS-ALTO-P (STRINGP HOST-ADDRESS) (PRINT-DOVER-STATUS))
    713         (PRESS-START-FILE (IF SEND-TO-MOONS-ALTO-P 926-ALTO-ADDRESS HOST-ADDRESS))
    714         (PRESS-START-PAGE)
    715         (PRESS-SELECT-FONT (PRESS-DEFINE-FONT FONT-NAME FACE-NAME FONT-SIZE 0))
    716         (DO ((CH (FUNCALL INPUT-STREAM ':TYI) (FUNCALL INPUT-STREAM ':TYI)))
    717             ((NULL CH))
    718           (PRESS-CHAR CH))
    719         (PRESS-END-PAGE)
    720         (PRESS-END-FILE FILE-NAME CREATION-DATE N-COPIES)))
    721     (CLOSE INPUT-STREAM)))
    722 
    723 ;Spool a file via MC's spooler
    724 (DEFUN SPOOL-FILE (FILE-NAME &OPTIONAL (FONT-NAME "TIMESROMAN")
    725                              (FACE-NAME "")
    726                              (FONT-SIZE 10.)
    727                              (PAGE-HEADINGS T)
    728                              (N-COPIES 1)
    729                              (FILE (FORMAT NIL "MC:.DOVR.;~A >" USER-ID)))
    730   (PRINT-FILE FILE-NAME FONT-NAME FACE-NAME FONT-SIZE PAGE-HEADINGS N-COPIES NIL FILE))
    731 
     799                             (HOST-ADDRESS DOVER-ADDRESS))
     800  ;; Special variables are just set rather than returned
     801  (DECLARE (RETURN-LIST FONT-NAME FACE-NAME FONT-SIZE PAGE-HEADINGS N-COPIES HOST-ADDRESS))
     802  (DO ((O OPTIONS (CDDR O)))
     803      ((NULL O))
     804    (SELECTQ (CAR O)
     805      (:FONT-NAME (SETQ FONT-NAME (CADR O)))
     806      (:FACE-NAME (SETQ FACE-NAME (CADR O)))
     807      (:FONT-SIZE (SETQ FONT-SIZE (CADR O)))
     808      (:FONT (MULTIPLE-VALUE (FONT-NAME FACE-NAME FONT-SIZE)
     809               (DECODE-FONT-NAME (CADR O))))
     810      (:PAGE-HEADINGS (SETQ PAGE-HEADINGS (CADR O)))
     811      (:COPIES (SETQ N-COPIES (CADR O)))
     812      (:HOST-ADDRESS (SETQ PRESS-USE-EFTP T
     813                           HOST-ADDRESS (CADR O)))
     814      (:FILE (SETQ HOST-ADDRESS (CADR O)
     815                   PRESS-USE-EFTP NIL))
     816      (:SPOOL (SETQ HOST-ADDRESS (FORMAT NIL "MC: .DOVR.; ~A >" USER-ID)
     817                    PRESS-USE-EFTP NIL))
     818      (:EFTP (SETQ HOST-ADDRESS DOVER-ADDRESS
     819                   PRESS-USE-EFTP T))
     820      (:XGP (SETQ PRESS-INTERPRET-XGP-ESCAPE T
     821                  PAGE-HEADINGS NIL))
     822      (OTHERWISE (FERROR NIL "~S is an unknown keyword" (CAR O)))))
     823  (VALUES FONT-NAME FACE-NAME FONT-SIZE PAGE-HEADINGS N-COPIES HOST-ADDRESS))
     824
     825(DEFUN DECODE-FONT-NAME (STRING &AUX IDX1 IDX2 (IBASE 10.))
     826  (DECLARE (RETURN-LIST FAMILY FACE SIZE))
     827  (OR (SETQ IDX1 (STRING-REVERSE-SEARCH-SET '(#/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9)
     828                                            STRING))
     829      (FERROR NIL "No point size in ~A" STRING))
     830  (SETQ IDX2 (1+ (STRING-REVERSE-SEARCH-NOT-SET '(#/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9)
     831                                                STRING IDX1)))
     832  (VALUES (SUBSTRING STRING 0 IDX2)
     833          (SUBSTRING STRING (1+ IDX1))
     834          (READ-FROM-STRING (SUBSTRING STRING IDX2 (1+ IDX1)))))
     835
     836
     837;;; XGP support
     838(DEFUN PRINT-XGP-FILE (FILE-NAME &REST OPTIONS)
     839  (WITH-OPEN-FILE (STREAM FILE-NAME '(:READ :RAW :SUPER-IMAGE))
     840    (LEXPR-FUNCALL #'PRINT-FROM-STREAM
     841                   (LET-CLOSED ((FILE-STREAM STREAM))
     842                     #'XGP-FILE-STREAM)
     843                   (FUNCALL STREAM ':TRUENAME) ':XGP T OPTIONS)))
     844
     845(DEFVAR XGP-STREAM-RAW-P NIL)
     846
     847;;; This extra level of stream is necessary, since sometimes we want character set conversion,
     848;;; as when reading text, and other times not, as when reading arguments.
     849(DEFUN XGP-FILE-STREAM (OP &REST ARGS)
     850  (DECLARE (SPECIAL FILE-STREAM))
     851  (SELECTQ OP
     852    (:WHICH-OPERATIONS '(:TYI :TRUENAME :CREATION-DATE))
     853    (:TYI
     854     (IF XGP-STREAM-RAW-P (FUNCALL FILE-STREAM ':TYI)
     855         (DO ((CH)) (NIL)
     856           (SETQ CH (FUNCALL FILE-STREAM ':TYI))
     857           (SELECTQ CH
     858             (11 (RETURN #\TAB))
     859             (12 )
     860             (14 (RETURN #\FF))
     861             (15 (RETURN #\CR))
     862             (OTHERWISE (RETURN CH))))))
     863    (:LINE-IN (STREAM-DEFAULT-HANDLER #'XGP-FILE-STREAM OP (CAR ARGS) (CDR ARGS)))
     864    (OTHERWISE (LEXPR-FUNCALL FILE-STREAM OP ARGS))))
     865
     866(DEFCONST XGP-DOTS-PER-INCH 200.)
     867
     868(DEFMACRO XGP-TO-MICAS (X)
     869  `(// (* ,X 2540.) XGP-DOTS-PER-INCH))
     870
     871(DEFUN PRESS-XGP-HEADER-PAGE (INPUT-STREAM &AUX LEFT-MARGIN TOP-MARGIN BOTTOM-MARGIN)
     872  (SETQ LEFT-MARGIN 2540.                       ;Closer to the xgp's values
     873        TOP-MARGIN (// (* 2540. 2) 3)
     874        BOTTOM-MARGIN TOP-MARGIN)                     
     875  (DO ((CH)) (NIL)
     876    (SELECTQ (SETQ CH (FUNCALL INPUT-STREAM ':TYI))
     877      (#\FORM (RETURN NIL))
     878      (#\CR)
     879      (#/;
     880       (LET* ((LINE (FUNCALL INPUT-STREAM ':LINE-IN))
     881              (IDX (STRING-SEARCH-CHAR #\SP LINE))
     882              (IBASE 10.))
     883         (SELECTOR (SUBSTRING LINE 0 (PROG1 IDX (AND IDX (INCF IDX)))) STRING-EQUAL
     884;          ("autcut")
     885           ("botmar"
     886            (SETQ BOTTOM-MARGIN (XGP-TO-MICAS (READ-FROM-STRING LINE NIL IDX))))
     887;          ("delete")
     888           ("dfont"
     889            (SETQ PRESS-XGP-FONT-LIST
     890                  (LOOP FOR I = IDX THEN (1+ J)
     891                        FOR J = (STRING-SEARCH-CHAR #/, LINE I)
     892                        COLLECT (MULTIPLE-VALUE-BIND (FAMILY FACE SIZE)
     893                                    (DECODE-FONT-NAME (SUBSTRING LINE I J))
     894                                  (PRESS-DEFINE-FONT FAMILY FACE SIZE 0))
     895                        WHILE J)))
     896           ("ffcut")
     897           ("lftmar"
     898            (SETQ LEFT-MARGIN (XGP-TO-MICAS (READ-FROM-STRING LINE NIL IDX))))
     899;          ("list")
     900           ("lsp"
     901            (SETQ PRESS-INTERLINE-SPACING (XGP-TO-MICAS (READ-FROM-STRING LINE NIL IDX))))
     902           ("rgtmar")
     903           ("skip")
     904           ("squish")
     905           ("topmar"
     906            (SETQ TOP-MARGIN (XGP-TO-MICAS (READ-FROM-STRING LINE NIL IDX))))
     907           ("vsp")
     908           (OTHERWISE (FERROR NIL "Unknown line ~A in XGP preamble" LINE)))))
     909      (OTHERWISE
     910       (FERROR NIL "Unknown character in XGP preamble ~C" CH))))
     911  (SETQ DOVER-X0 LEFT-MARGIN
     912        DOVER-Y1 (- (* 11. 2540.) TOP-MARGIN BOTTOM-MARGIN PRESS-INTERLINE-SPACING)
     913        DOVER-Y2 BOTTOM-MARGIN))
     914
     915(DEFUN PRESS-XGP-ESCAPE (INPUT-STREAM &AUX (XGP-STREAM-RAW-P T) CH)
     916  (SELECTQ (SETQ CH (FUNCALL INPUT-STREAM ':TYI))
     917    (1 (PRESS-XGP-ESCAPE-1 INPUT-STREAM))
     918    (2 (PRESS-XGP-ESCAPE-2 INPUT-STREAM))
     919    (3 (PRESS-XGP-ESCAPE-3 INPUT-STREAM))
     920    (4 (PRESS-XGP-ESCAPE-4 INPUT-STREAM))
     921    (OTHERWISE (PRESS-CHAR CH))))
     922
     923(DEFUN PRESS-XGP-ESCAPE-1 (INPUT-STREAM &AUX CH)
     924  (SETQ CH (FUNCALL INPUT-STREAM ':TYI))
     925  (IF (< CH 20)
     926      (PRESS-SELECT-FONT (NTH CH PRESS-XGP-FONT-LIST))
     927      (SELECTQ CH
     928        (40 (PRESS-XGP-SET-COLUMN INPUT-STREAM))
     929        (41 (PRESS-XGP-UNDERSCORE INPUT-STREAM))
     930        (42 (PRESS-XGP-LINE-SPACE INPUT-STREAM))
     931        (43 (PRESS-XGP-BASELINE-ADJUST INPUT-STREAM))
     932        (44 (PRESS-XGP-PRINT-PAGE-NUMBER INPUT-STREAM))
     933        (45 (PRESS-XGP-SPECIFY-HEADING INPUT-STREAM))
     934        (46 (PRESS-XGP-START-UNDERSCORE INPUT-STREAM))
     935        (47 (PRESS-XGP-END-UNDERSCORE INPUT-STREAM))
     936        (50 (PRESS-XGP-SET-INTERCHAR-SPACING INPUT-STREAM))
     937        (51 (PRESS-XGP-END-SPECIFIED-WIDTH-UNDERSCORE INPUT-STREAM))
     938        (52 (PRESS-XGP-RELATIVE-BASELINE-ADJUST INPUT-STREAM))
     939        (53 (PRESS-XGP-RELATIVE-UNDERSCORE INPUT-STREAM))
     940        (OTHERWISE (FERROR NIL "Unknown XGP escape ~O" CH)))))
     941
     942;;; Sign extended version of above
     943(DEFUN PRESS-XGP-ONE-BYTE-ARG (INPUT-STREAM)
     944  (LET ((CH (FUNCALL INPUT-STREAM ':TYI)))
     945    (IF (BIT-TEST 100 CH) (- 200 CH) CH)))
     946
     947(DEFUN PRESS-XGP-TWO-BYTE-ARG (INPUT-STREAM)
     948  (DPB (FUNCALL INPUT-STREAM ':TYI) 0707 (FUNCALL INPUT-STREAM ':TYI)))
     949
     950(DEFUN PRESS-XGP-THREE-BYTE-ARG (INPUT-STREAM)
     951  (DPB (FUNCALL INPUT-STREAM ':TYI) 1607
     952       (DPB (FUNCALL INPUT-STREAM ':TYI) 0707 (FUNCALL INPUT-STREAM ':TYI))))
     953
     954(DEFUN PRESS-XGP-SET-COLUMN (INPUT-STREAM)
     955  (PRESS-SET-CURSOR (XGP-TO-MICAS (PRESS-XGP-TWO-BYTE-ARG INPUT-STREAM)) PRESS-Y))
     956
     957(DEFUN PRESS-XGP-UNDERSCORE (INPUT-STREAM)
     958  (PRESS-XGP-DO-UNDERSCORE (- PRESS-Y (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM)))
     959                           PRESS-X (PRESS-XGP-TWO-BYTE-ARG INPUT-STREAM) 2.))
     960
     961(DEFUN PRESS-XGP-LINE-SPACE (INPUT-STREAM)
     962  (SETQ PRESS-INTERCHAR-SPACING NIL)
     963  (PRESS-SET-CURSOR PRESS-X (- PRESS-Y (XGP-TO-MICAS (FUNCALL INPUT-STREAM ':TYI)))))
     964
     965(DEFUN PRESS-XGP-BASELINE-ADJUST (INPUT-STREAM)
     966  (SETQ PRESS-INTERCHAR-SPACING NIL)
     967  (PRESS-SET-CURSOR
     968    (SETQ PRESS-BASELINE-Y (+ PRESS-Y (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM))))
     969    PRESS-X))
     970
     971(DEFUN PRESS-XGP-PRINT-PAGE-NUMBER (IGNORE)
     972  (PRESS-STRING (FORMAT NIL "~D" PRESS-PAGE-NUMBER)))
     973
     974(DEFUN PRESS-XGP-SPECIFY-HEADING (INPUT-STREAM)
     975  (LET* ((LENGTH (FUNCALL INPUT-STREAM ':TYI))
     976         (STRING (MAKE-ARRAY LENGTH ':TYPE 'ART-STRING)))
     977    (LOOP FOR I FROM 0 BELOW LENGTH
     978          DO (ASET (FUNCALL INPUT-STREAM ':TYI) STRING I))
     979    (SETQ PRESS-END-PAGE-HOOK (LET-CLOSED ((STRING STRING))
     980                                #'(LAMBDA ()
     981                                    (FORMAT T "~D " PRESS-PAGE-NUMBER)
     982                                    (WITH-INPUT-FROM-STRING (INPUT-STREAM STRING)
     983                                      (DO ((CH))
     984                                          ((NULL (SETQ CH (FUNCALL INPUT-STREAM ':TYI))))
     985                                        (IF (AND PRESS-INTERPRET-XGP-ESCAPE (= CH 177))
     986                                            (PRESS-XGP-ESCAPE INPUT-STREAM)
     987                                            (PRESS-CHAR CH)))))))))
     988
     989(DEFUN PRESS-XGP-START-UNDERSCORE (IGNORE)
     990  (SETQ PRESS-XGP-UNDERLINE-START-X PRESS-X))
     991
     992(DEFUN PRESS-XGP-END-UNDERSCORE (INPUT-STREAM)
     993  (PRESS-XGP-DO-UNDERSCORE (- PRESS-BASELINE-Y
     994                              (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM)))
     995                           PRESS-XGP-UNDERLINE-START-X
     996                           PRESS-X 2.))
     997
     998(DEFUN PRESS-XGP-SET-INTERCHAR-SPACING (INPUT-STREAM)
     999  (SETQ PRESS-INTERCHAR-SPACING (XGP-TO-MICAS (FUNCALL INPUT-STREAM ':TYI))))
     1000
     1001(DEFUN PRESS-XGP-END-SPECIFIED-WIDTH-UNDERSCORE (INPUT-STREAM)
     1002  (LET ((WIDTH (FUNCALL INPUT-STREAM ':TYI)))
     1003    (PRESS-XGP-DO-UNDERSCORE (- PRESS-BASELINE-Y
     1004                                (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM)))
     1005                             PRESS-XGP-UNDERLINE-START-X
     1006                             PRESS-X WIDTH)))
     1007
     1008(DEFUN PRESS-XGP-RELATIVE-BASELINE-ADJUST (INPUT-STREAM)
     1009  (PRESS-SET-CURSOR
     1010    (SETQ PRESS-BASELINE-Y (+ PRESS-BASELINE-Y
     1011                              (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM))))
     1012    PRESS-X))
     1013
     1014(DEFUN PRESS-XGP-RELATIVE-UNDERSCORE (INPUT-STREAM)
     1015  (PRESS-XGP-DO-UNDERSCORE (- PRESS-BASELINE-Y
     1016                              (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM)))
     1017                           PRESS-X (PRESS-XGP-TWO-BYTE-ARG INPUT-STREAM) 2.))
     1018
     1019(DEFUN PRESS-XGP-DO-UNDERSCORE (TOP-Y X-START X-END THICKNESS &AUX (OX PRESS-X) (OY PRESS-Y))
     1020  (PRESS-SET-CURSOR X-START (- TOP-Y THICKNESS))
     1021  (PRESS-ENTITY-BYTE 376)       ;Show-rectangle
     1022  (PRESS-ENTITY-WORD (- X-END X-START))         ;Width
     1023  (PRESS-ENTITY-WORD (XGP-TO-MICAS THICKNESS))  ;Thickness
     1024  (PRESS-SET-CURSOR OX OY))
     1025
     1026(DEFUN PRESS-XGP-ESCAPE-2 (INPUT-STREAM)
     1027  (PRESS-SET-CURSOR (+ PRESS-X (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM)))
     1028                    PRESS-Y))
     1029
     1030(DEFUN PRESS-XGP-ESCAPE-3 (IGNORE)
     1031  (FERROR NIL "XGP escape 3 not implemented"))
     1032
     1033(DEFUN PRESS-XGP-ESCAPE-4 (IGNORE)
     1034  (FERROR NIL "XGP escape 4 not implemented"))
    7321035
    7331036
     
    7371040; rotation is optional and defaults to 0
    7381041(DEFUN SAMPLE-FONTS (FONT-LIST &OPTIONAL (UPPER-HALF NIL)
    739                                          (SEND-TO-MOONS-ALTO-P NIL)
    7401042                                         (HOST-ADDRESS DOVER-ADDRESS)
    741                                &AUX (PRESS-USE-EFTP PRESS-USE-EFTP) FOO CH)
    742   (AND SEND-TO-MOONS-ALTO-P (SETQ PRESS-USE-EFTP T))
    743   (OR SEND-TO-MOONS-ALTO-P (STRINGP HOST-ADDRESS) (PRINT-DOVER-STATUS))
    744   (PRESS-START-FILE (IF SEND-TO-MOONS-ALTO-P 926-ALTO-ADDRESS HOST-ADDRESS))
     1043                               &AUX FOO CH)
     1044 (BIND-PRESS-VARIABLES
     1045  (PRESS-START-FILE HOST-ADDRESS)
    7451046  (LET ((LABEL-FONT (PRESS-DEFINE-FONT "TIMESROMAN" "" 10. 0)) THIS-FONT NOT-IN-FONTS-WIDTHS)
    7461047    (DO ((L FONT-LIST (CDR L))
     
    7521053      (COND ((= I 16.)                          ;Got to make a new file
    7531054             (PRESS-END-FILE "Font samples" "")
    754              (RETURN (SAMPLE-FONTS L UPPER-HALF SEND-TO-MOONS-ALTO-P))))
     1055             (RETURN (SAMPLE-FONTS L UPPER-HALF))))
    7551056      (PRESS-START-PAGE)
    7561057      (MULTIPLE-VALUE (THIS-FONT NOT-IN-FONTS-WIDTHS)
     
    7881089      (PRESS-CHAR-SEQ #/! #/?)
    7891090      (PRESS-CHAR-SEQ #/[ #/_)
    790       (PRESS-CHAR-SEQ #/{ #/‡ #\CR)
     1091      (PRESS-CHAR-SEQ #/{ #/ #\CR)
    7911092      (PRESS-CHAR-SEQ #/ #/)
    7921093      (PRESS-SET-CURSOR 0 4150.)
     
    8071108      (PRESS-SET-CURSOR 8750. PRESS-Y)
    8081109      (PRESS-STRING "             (T (CONS (CAR X) (APPEND (CDR X) Y)))))")
    809       (PRESS-END-PAGE))))
     1110      (PRESS-END-PAGE)))))
    8101111
    8111112(DEFUN PRESS-CHAR-SEQ (FIRST LAST &OPTIONAL EXTRA)
     
    8741175
    8751176  (TEMPLATE || 64.) ))
     1177
     1178;; Read in all fonts from FONTS;DOVER FONTS
     1179(DEFUN COMPUTE-DOVER-FONTS (&AUX NAME FACE POINT ROT TEM ANSWER (IBASE 10.))
     1180  (WITH-OPEN-FILE (I "AI: FONTS; DOVER FONTS")
     1181    (DO ((LINE) (EOF)) (NIL)
     1182      (MULTIPLE-VALUE (LINE EOF)
     1183        (FUNCALL I ':LINE-IN))
     1184      (AND EOF
     1185           (OR (NULL LINE) (EQUAL LINE ""))
     1186           (RETURN (NREVERSE ANSWER)))
     1187      (SETQ TEM (STRING-SEARCH-CHAR #/, LINE)
     1188            NAME (INTERN (SUBSTRING LINE 7 TEM) "PRESS")
     1189            TEM (+ TEM 2)
     1190            FACE (COND ((STRING-EQUAL LINE "MR" TEM 0 (+ TEM 2) 2) '||)
     1191                       ((STRING-EQUAL LINE "MI" TEM 0 (+ TEM 2) 2) 'I)
     1192                       ((STRING-EQUAL LINE "BR" TEM 0 (+ TEM 2) 2) 'B)
     1193                       ((STRING-EQUAL LINE "BI" TEM 0 (+ TEM 2) 2) 'BI)
     1194                       (T (FERROR NIL "Parsing error in fonts file.")))
     1195            TEM (1+ (STRING-SEARCH-CHAR #/( LINE TEM))
     1196            POINT (READ-FROM-STRING LINE 'SI:NO-EOF-OPTION TEM)
     1197            TEM (+ (STRING-SEARCH-CHAR #/: LINE TEM) 2)
     1198            ROT (READ-FROM-STRING LINE 'SI:NO-EOF-OPTION TEM))
     1199      (PUSH (LIST NAME FACE POINT ROT) ANSWER))))
     1200
    8761201
    8771202
     
    9021227  (PRESS-END-FILE "Lines" ""))
    9031228);comment
     1229
     1230
     1231;;; ZWEI interface
     1232;;; should have a way of setting this stuff
     1233(DEFVAR DIRED-PRINT-OPTIONS NIL)
     1234
     1235(DEFUN (:DOVER :DIRED-PRINT-FUNCTION) (PATHNAME TYPE)
     1236  (SELECTQ TYPE
     1237    (:SUDS-PLOT
     1238     (AND (NOT (FBOUNDP ':DPLT-PRINT-FILE))
     1239          (LOAD "SYS: IO1; DPLT PKG >")
     1240          (PKG-LOAD 'DPLT '(:NOCONFIRM)))
     1241     (:DPLT-PRINT-FILE PATHNAME)
     1242     T)
     1243    (:XGP
     1244     (LEXPR-FUNCALL #'PRINT-XGP-FILE PATHNAME DIRED-PRINT-OPTIONS))
     1245    (:TEXT (LEXPR-FUNCALL #'PRINT-FILE PATHNAME DIRED-PRINT-OPTIONS))
     1246    (:PRESS (LEXPR-FUNCALL #'PRINT-PRESS-FILE PATHNAME DIRED-PRINT-OPTIONS))
     1247    (OTHERWISE (FORMAT NIL "I don't know how to print files of type ~A" TYPE))))
     1248
  • trunk/lisp/lmio1/promp.lisp

    r252 r288  
    33;;; Routines to hack the prom programmer
    44;;; Type "Select F1 Start" on the "System 19" to put it in remote mode
    5 ;;; This program operates at 300 baud
     5;;; This program operates at 300 baud at MIT but at 1200 baud at Symbolics.
     6;;; Other sites should edit in whatever speed they prefer.
    67
    78;;; Modified 8/8/79 by Moon to use the IOB serial interface
     
    7475  (OR (BOUNDP 'PROGRAMMER-STREAM)
    7576      (SETQ PROGRAMMER-STREAM (SI:MAKE-SERIAL-STREAM
    76                                 ':PARITY NIL ':NUMBER-OF-DATA-BITS 8 ':BAUD 300.)))
     77                                ':PARITY NIL
     78                                ':NUMBER-OF-DATA-BITS 8
     79                                ':BAUD #+MIT 300. #+SYM 1200.)))
    7780  (FUNCALL PROGRAMMER-STREAM ':CLEAR-INPUT)
    7881  (FUNCALL PROGRAMMER-STREAM ':TYO 33)          ;This resets the programmer
     
    107110(DEFUN PROGRAMMER-READ-RAM (&OPTIONAL (ARRAY (MAKE-ARRAY NIL 'ART-8B
    108111                                                         (1+ PROGRAMMER-DEVICE-WORD-LIMIT))))
     112  (PROGRAMMER-RESET)
    109113  (MULTIPLE-VALUE-BIND (IGNORE FAILURE)
    110114      (PROGRAMMER-COMMAND "83A" NIL)
     
    112116         (FERROR NIL "Cannot set transfer format"))
    113117    (PROGRAMMER-COMMAND "O" 'NONE)
    114     (DO ((BYTE-COUNT) (PROGRAMMER-CHECKSUM 0 0) (ADR 0) (CS) (RECORD-TYPE))
     118    (DO ((BYTE-COUNT) (PROGRAMMER-CHECKSUM 0 0) (ADR 0) (CS) (RECORD-TYPE)
     119         (ARRAY-LEN (ARRAY-LENGTH ARRAY)))
    115120        (())
    116121      ;Start character is a colon
     
    121126      (SELECTQ RECORD-TYPE
    122127        (00                                     ;Data record
     128         (COND ((
     129 ADR ARRAY-LEN)
     130                ;; With the new software, it seems that the programmer can overrun the array
     131                (FORMAT T "~&Programmer sending too much data, resetting.")
     132                (PROGRAMMER-RESET)
     133                (RETURN NIL)))
    123134         (DOTIMES (I BYTE-COUNT)
    124            (ASET (HEX-READ-BYTE) ARRAY (+ ADR I)))
     135           (LET ((BYTE (HEX-READ-BYTE)))
     136             (AND  (< (+ ADR I) ARRAY-LEN)
     137                   (ASET BYTE ARRAY (+ ADR I)))))
    125138         (SETQ CS (LOGAND (- PROGRAMMER-CHECKSUM) 377))
    126139         (COND (( (SETQ RECORD-TYPE (HEX-READ-BYTE)) CS)
     
    244257     (PROGRAMMER-COMMAND "P"))
    245258   (COND (FAIL
    246           (FORMAT T "&~Programming failed.")
     259          (FORMAT T "~&Programming failed.")
    247260          (RETURN NIL)))
    248261   (FORMAT T "~&Verifying device.")
     
    320333    (OR FROM (DO () ((PROGRAMMER-PROGRAM-PROM (CAR PROM))))))
    321334  'DONE)
     335
  • trunk/lisp/lmio1/reldmp.lisp

    r253 r288  
    1 ;-*-Mode: Lisp; Package: QFASL-REL-*-
     1;-*-Mode: Lisp; Package: QFASL-REL; Lowercase: T-*-
    22
    33;Temporary area for data structures used in dumping.
     
    114114;Dump the file property list
    115115;as a bunch of defprops to be evaluated at load time.
    116 (defun dump-file-property-list (file-group-symbol plist)
     116(defun dump-file-property-list (generic-pathname plist)
     117  (dump-form `(set-generic-pathname-property-list
     118                ;; Cannot fasd instances yet.
     119                ,(funcall generic-pathname ':string-for-printing)
     120                ,plist)))
     121
     122(defun set-generic-pathname-property-list (generic-pathname-string plist &aux pathname)
     123  (setq pathname (funcall (fs:merge-pathname-defaults generic-pathname-string)
     124                          ':generic-pathname))
    117125  (do ((l plist (cddr l))) ((null l))
    118     (dump-form `(defprop ,file-group-symbol (cadr l) (car l)))))
     126    (funcall pathname ':putprop (cadr l) (car l))))
    119127
    120128;Dump a form to be evaluated at load time.
  • trunk/lisp/lmio1/relld.lisp

    r253 r288  
    427427               (set form (%p-contents-offset org (setq i (1+ i)))))
    428428              ((= type 2)
    429                (prog (tem si:fdefine-file-symbol)
     429               (prog (tem si:fdefine-file-pathname)
    430430                     (setq tem (%p-contents-offset org (setq i (1+ i)))
    431                            si:fdefine-file-symbol (%p-contents-offset org (setq i (1+ i))))
     431                           si:fdefine-file-pathname (%p-contents-offset org (setq i (1+ i))))
    432432                     (fset-carefully form tem))))))))
    433433
  • trunk/lisp/lmio1/rfontw.lisp

    r254 r288  
    77
    88(declare (special font-width-data))
     9#Q (declare (setq run-in-maclisp-switch t))
    910
    1011;Interesting functions:
     
    1213;       loads up the file.  Takes an optional argument of the filename
    1314;       of the widths file (defaults to FONTS; FONTS WIDTHS).
     15;       If a second optional argument is supplied, it is a list of
     16;       lists (family-name face-name point-size) and only those
     17;       specific fonts are loaded, to avoid running out of pdp-10
     18;       address space.
    1419;       Merges with pre-existing contents of FONT-WIDTH-DATA (set it
    1520;       to NIL first if you want to flush the old data.)
     
    4752
    4853
     54#M (eval-when (compile eval)
     55        (defmacro with-open-file ((var filename options) . body)
     56                  `(let ((,var (open ,filename ,options)))
     57                     ,@body
     58                     (close ,var))))
     59
    4960(declare (special widths-file code-alist #M widths-file-next-word))
    5061
     
    5566#M (declare (fixnum (next-word) (widths-file-pos) i j k m n wd))
    5667
    57 (eval-when (compile eval)
     68(eval-when (compile eval #q load)
    5869(defmacro high-byte (word)
    5970  `(lsh ,word -8))
     
    7485  #Q (funcall widths-file ':tyi "Unexpected EOF on widths file"))
    7586
    76 
    7787(defun widths-file-pos ()
    7888   #M (- (* 2 (filepos widths-file))
     
    8898
    8999             
    90 (defun bcpl-string (n) ;n = max-length-including-header-byte and is even
     100(defun bcpl-string (n widths-file) ;n = max-length-including-header-byte and is even
    91101  (let ((wd (next-word)))
    92102      (do ((chlist #M nil #Q (make-array nil 'art-string (high-byte wd)))
     
    113123      (list 'code code)))
    114124
    115 (defun decode-face (face-code)
    116   (declare (fixnum face-code))
    117   (let ((l nil))
     125;Normal face codes are || for normal, I for italic, B for bold, etc.
     126;These are strings rather than symbols on the Lisp machine.
     127;Alternatively the face code can be a list of the normal code,
     128;the CMU character-set-convention code, and the TEX logical size code.
     129(defun decode-face (face-code2)
     130  (declare (fixnum face-code2))
     131  (let ((l nil)
     132        (res nil)
     133        (face-code (\ face-code2 18.))
     134        (cmu-bullshit (\ (// face-code2 18.) 3))
     135        (tex-bullshit (if (< face-code2 54.) -1 (- face-code2 54.))))
     136    (declare (fixnum face-code cmu-bullshit tex-bullshit))
    118137    (cond ((> face-code 11.)
    119138           (setq face-code (- face-code 12.))
     
    133152    (cond ((not (zerop face-code))
    134153           (error '|extra garbage in face-code| face-code)))
    135  #M (implode l)
    136  #Q (fillarray (make-array nil 'art-string (length l)) l)))
     154    (setq res #M (implode l)
     155              #Q (fillarray (make-array (length l) ':type 'art-string) l))
     156    (cond ((or (not (zerop cmu-bullshit)) (not (minusp tex-bullshit)))
     157           (setq res (list res cmu-bullshit))
     158           (or (minusp tex-bullshit)
     159               (setq res (nconc res (list tex-bullshit))))))
     160    res))
    137161
    138162;Load it up and make the data structure mentioned at front of file
    139 (defun load-font-widths (&optional (filename '|dsk:fonts;fonts widths|))
    140   (let ((widths-file (open filename '(read fixnum)))
    141         (code-alist nil)
    142         (segment-data nil)
    143         (wd 0))
    144  #M (store (arraycall fixnum widths-file-next-word 0) -1)
    145     (setq wd (next-word))
    146     ;; Read IXN entries (type 1)
    147     (do () ((not (= (lsh wd -12.) 1)))
    148       (let ((code (next-word))
    149             (name (bcpl-string 20.)))
    150         (push (cons code name) code-alist))
    151       (setq wd (next-word)))
    152     ;; Read WidthIndexEntries (type 4)
    153     (do () ((not (= (lsh wd -12.) 4)))
    154       (setq wd (next-word))             ;family,,face
    155       (push (list (code-to-name (high-byte wd))         ;Family-name
    156                   (decode-face (low-byte wd))           ;Face name
    157                   (progn (setq wd (next-word))          ;bc,,ec
    158                          (high-byte wd))                ;First code
    159                   (low-byte wd)                         ;Last code
    160                   (next-word)                           ;Size
    161                   (next-word)                           ;Rotation
    162                   (+ (lsh (next-word) 16.) (next-word)) ;Segment SA
    163                   (+ (lsh (next-word) 16.) (next-word)));Segment Len
    164             segment-data)
    165       (setq wd (next-word)))
    166     ;; Now should have type-0 entry (end of index)
    167     (or (zerop (lsh wd -12.))
    168         (error '|Bullshit in file where type 0 IX expected| wd))
    169     ;; Now read out the WidthSegments, which should follow
    170     ;; immediately with no gaps.  Sort segments by SA
    171     ;; Hmm, now it seems gaps are allowed, so we skip them.
    172     (setq segment-data (sort segment-data
    173                              #'(lambda (x y)
    174                                  (< (cadddr (cdddr x)) (cadddr (cdddr y))))))
    175     (or (boundp 'font-width-data)
    176         (setq font-width-data nil))
    177     (do ((segment-data segment-data (cdr segment-data))
    178          (seg) (bb) (m 0) (xwidths) (ywidths))
    179         ((null segment-data))
    180       (setq seg (car segment-data))
    181       (let ((gap (- (cadddr (cdddr seg)) (widths-file-pos))))
    182         #M (declare (fixnum gap))
    183         (cond ((minusp gap) (break file-out-of-phase t)))
    184         (dotimes (i gap) (next-word)))
    185       (setq bb (list (next-word2) (next-word2) (next-word2) (next-word2)))
    186       (setq m (next-word))                              ;Flags
    187         ;Note that the documentation on this flags word is wrong!
    188       ;; Process X-data
    189       (cond ((not (zerop (boole 1 100000 m)))
    190              (setq xwidths (next-word)))
    191             (t (setq xwidths (*array nil 'fixnum 400))
    192                (fillarray xwidths '(-1))        ;Chars not in bc..ec have -1
    193                (do ((j (caddr seg) (1+ j))
    194                     (k 0))
    195                    ((> j (cadddr seg)))
    196                  (setq k (next-word))
    197                  (and (= k 100000) (setq k -1))
    198                  (store (arraycall fixnum xwidths j) k))))
    199       ;; Process Y-data
    200       (cond ((not (zerop (boole 1 40000 m)))
    201              (setq ywidths (next-word)))
    202             (t (setq ywidths (*array nil 'fixnum 400))
    203                (fillarray xwidths '(-1))        ;Chars not in bc..ec have -1
    204                (do ((j (caddr seg) (1+ j))
    205                     (k 0))
    206                    ((> j (cadddr seg)))
    207                  (setq k (next-word))
    208                  (and (= k 100000) (setq k -1))
    209                  (store (arraycall fixnum ywidths j) k))))
    210       ;; Make the data
    211       (push (list (car seg) (cadr seg) (car (cddddr seg)) (cadr (cddddr seg))
    212                   bb xwidths ywidths)
    213             font-width-data))
    214     (close widths-file)))
     163(defun load-font-widths (&optional filename fonts-desired)
     164  (with-open-file (widths-file (or filename '((dsk fonts)fonts widths))
     165                               '(read fixnum))
     166    (let ((code-alist nil)
     167          (segment-data nil)
     168       #M (noret t)     ; don't play musical corblk while loading stuff
     169          (wd 0))
     170      ; guestimate core needed:
     171   #M (let ((max-guess (* 3 (lengthf widths-file))))
     172        (declare (fixnum max-guess))
     173        (and fonts-desired (let ((new-guess (* 800 (length fonts-desired))))
     174                             (declare (fixnum new-guess))
     175                             (and (< new-guess max-guess)
     176                                  (setq max-guess new-guess))))
     177        (getsp max-guess))
     178   #M (store (arraycall fixnum widths-file-next-word 0) -1)
     179      (setq wd (next-word))
     180      ;; Read IXN entries (type 1)
     181      (do () ((not (= (lsh wd -12.) 1)))
     182        (let ((code (next-word))
     183              (name (bcpl-string 20. widths-file)))
     184          (push (cons code name) code-alist))
     185        (setq wd (next-word)))
     186      ;; Read WidthIndexEntries (type 4)
     187      (do () ((not (= (lsh wd -12.) 4)))
     188        (setq wd (next-word))           ;family,,face
     189        (push (list (code-to-name (high-byte wd))               ;Family-name
     190                    (decode-face (low-byte wd))         ;Face name
     191                    (progn (setq wd (next-word))                ;bc,,ec
     192                           (high-byte wd))              ;First code
     193                    (low-byte wd)                               ;Last code
     194                    (next-word)                         ;Size
     195                    (next-word)                         ;Rotation
     196                    (+ (lsh (next-word) 16.) (next-word))       ;Segment SA
     197                    (+ (lsh (next-word) 16.) (next-word)));Segment Len
     198              segment-data)
     199        (setq wd (next-word)))
     200      ;; Now should have type-0 entry (end of index)
     201      (or (zerop (lsh wd -12.))
     202          (error '|Bullshit in file where type 0 IX expected| wd))
     203      ;; Now read out the WidthSegments, which should follow
     204      ;; immediately with no gaps.  Sort segments by SA
     205      ;; Hmm, now it seems gaps are allowed, so we skip them.
     206      ;; Also skip entries for fonts not in fonts-desired if it is non-nil.
     207      (setq segment-data (sort segment-data
     208                               #'(lambda (x y)
     209                                   (< (cadddr (cdddr x)) (cadddr (cdddr y))))))
     210      (or (boundp 'font-width-data)
     211          (setq font-width-data nil))
     212      (do ((segment-data segment-data (cdr segment-data))
     213           (seg) (bb) (m 0) (xwidths) (ywidths))
     214          ((null segment-data))
     215        (setq seg (car segment-data))
     216        (let ((gap (- (cadddr (cdddr seg)) (widths-file-pos))))
     217          #M (declare (fixnum gap))
     218          (cond ((minusp gap) (break file-out-of-phase t)))
     219          (dotimes (i gap) (next-word)))
     220        (setq bb (list (next-word2) (next-word2) (next-word2) (next-word2)))
     221        (setq m (next-word))                            ;Flags
     222          ;Note that the documentation on this flags word is wrong!
     223        (cond ((or (null fonts-desired)
     224                   (loop for f in fonts-desired
     225                         thereis (and (equal (car f) (car seg))  ;family
     226                                      (equal (cadr f) (cadr seg)) ;face
     227                                      (or (zerop (car (cddddr seg))) ;general
     228                                          (point-size-equal     ;specific
     229                                              (car (cddddr seg)) (caddr f)))
     230                                      (zerop (cadr (cddddr seg))) ;no rotation
     231                                      )))
     232               ;; Process X-data
     233               (cond ((not (zerop (boole 1 100000 m)))
     234                      (setq xwidths (next-word)))
     235                     (t (setq xwidths (*array nil 'fixnum 400))
     236                        (fillarray xwidths '(-1))       ;Chars not in bc..ec
     237                        (do ((j (caddr seg) (1+ j))
     238                             (k 0))
     239                            ((> j (cadddr seg)))
     240                          (setq k (next-word))
     241                          (and (= k 100000) (setq k -1))
     242                          (store (arraycall fixnum xwidths j) k))))
     243               ;; Process Y-data
     244               (cond ((not (zerop (boole 1 40000 m)))
     245                      (setq ywidths (next-word)))
     246                     (t (setq ywidths (*array nil 'fixnum 400))
     247                        (fillarray xwidths '(-1))       ;Chars not in bc..ec
     248                        (do ((j (caddr seg) (1+ j))
     249                             (k 0))
     250                            ((> j (cadddr seg)))
     251                          (setq k (next-word))
     252                          (and (= k 100000) (setq k -1))
     253                          (store (arraycall fixnum ywidths j) k))))
     254               ;; Make the data
     255               (push (list (car seg) (cadr seg) (car (cddddr seg))
     256                           (cadr (cddddr seg)) bb xwidths ywidths)
     257                     font-width-data))
     258              (t        ;Skip this font
     259               ;; Skip X-data
     260               (cond ((not (zerop (boole 1 100000 m)))
     261                      (next-word))
     262                     (t (do ((j (caddr seg) (1+ j)))
     263                            ((> j (cadddr seg)))
     264                          (next-word))))
     265               ;; Skip Y-data
     266               (cond ((not (zerop (boole 1 40000 m)))
     267                      (next-word))
     268                     (t (do ((j (caddr seg) (1+ j)))
     269                            ((> j (cadddr seg)))
     270                          (next-word))))))))
     271 #Q (si:set-file-loaded-id (funcall widths-file ':pathname) (funcall widths-file ':info)
     272                           package)
     273    ))
    215274
    216275;This will return the entry for the particular size if it
    217276;can find it, otherwise the entry for relative size.
     277;Errors out if no info found.
    218278(defun find-font-data (family-name face-name point-size)
     279  (or (find-font-data-1 family-name face-name point-size)
     280      (error '|No information for font|
     281             (list family-name face-name point-size))))
     282
     283;This will return the entry for the particular size if it
     284;can find it, otherwise the entry for relative size.
     285;Returns NIL if no info found.
     286(defun find-font-data-1 (family-name face-name point-size)
    219287 #Q (setq family-name (string family-name) face-name (string face-name))
    220288    (or (do l font-width-data (cdr l) (null l)
    221289          (and (equal (caar l) family-name)
    222290               (equal (cadar l) face-name)
    223                ;(= (// (* (caddar l) 72.) 2540.) point-size)
    224                ;The above does not work.  Apparently Xerox just plain is not consistent
    225                ;about how many points there are in an inch.  It doesn't help that their
    226                ;font documentation is riddled with errors.  So we'll do something extremely
    227                ;forgiving.
    228                (> (caddar l) (// (- (* point-size 2540.) 1270.) 72.))
    229                (< (caddar l) (// (+ (* point-size 2540.) 1270.) 72.))
     291               (point-size-equal (caddar l) point-size)
    230292               (zerop (cadddr (car l)))                 ;No rotation
    231293               (return (car l))))
     
    235297               (zerop (caddar l))
    236298               (zerop (cadddr (car l)))                 ;No rotation
    237                (return (car l))))
    238         (error '|No information for font|
    239                (list family-name face-name point-size))))
     299               (return (car l))))))
     300
     301(defun point-size-equal (internal point-size)
     302  (and ;(= (// (* internal 72.) 2540.) point-size)
     303       ;The above does not work.  Apparently Xerox just plain is not consistent
     304       ;about how many points there are in an inch.  It doesn't help that their
     305       ;font documentation is riddled with errors.  So we'll do something
     306       ;extremely forgiving.
     307       (> internal (// (- (* point-size 2540.) 1270.) 72.))
     308       (< internal (// (+ (* point-size 2540.) 1270.) 72.))))
    240309
    241310; (GET-FONT-WIDTH-DATA family-name face-name point-size)
     
    283352            ((list (// (* (caddr bb) point-size 2540.) 72000.)
    284353                   (// (* (cadddr bb) point-size 2540.) 72000.)))))))
    285 
    286 
    287 (comment ;This does not even compile!
    288 (if-for-lispm
    289 ;Read in an AC file as a Lisp machine font.
    290 (defun load-font (filename &optional family-name face-name point-size)
    291  (unwind-protect
    292   (let ((widths-file (open filename '(read fixnum)))
    293         (code-alist nil)
    294         (segment-data nil)
    295         family-code tem segment
    296         (wd 0))
    297     (setq wd (next-word))
    298     ;; Read IXN entries (type 1)
    299     (do () ((not (= (lsh wd -12.) 1)))
    300       (let ((code (next-word))
    301             (name (bcpl-string 20.)))
    302         (push (cons code name) code-alist))
    303       (setq wd (next-word)))
    304     ;; Find out the code number for the font family to be used,
    305     ;; either the specified one or the only one.
    306     (cond (family-name (setq family-code (name-to-code family-name)))
    307           ((cdr code-alist)
    308            (ferror nil "Font dictionary ~A: font family not specified" filename))
    309           (t (setq family-code (caar code-alist))))
    310     ;; Read Index Entries (type 3) for AC segments.
    311     (do () ((not (= (lsh wd -12.) 4)))
    312       (setq wd (next-word))             ;family,,face
    313       (setq tem
    314             (list (high-byte wd)                        ;Family code number.
    315                   (decode-face (low-byte wd))           ;Face name
    316                   (progn (setq wd (next-word))          ;bc,,ec
    317                          (high-byte wd))                ;First code
    318                   (low-byte wd)                         ;Last code
    319                   (next-word)                           ;Size
    320                   (next-word)                           ;Rotation
    321                   (+ (lsh (next-word) 16.) (next-word)) ;Segment SA
    322                   (+ (lsh (next-word) 16.) (next-word))));Segment Len
    323       (next-word) (next-word)                   ;Ignore resolution values.
    324       (and (= (car tem) family-code) (push tem segment-data))
    325       (setq wd (next-word)))
    326     ;; Now should have type-0 entry (end of index)
    327     (or (zerop (lsh wd -12.))
    328         (error '|Bullshit in file where type 0 IX expected| wd))
    329     ;; Now either there should be only one segment or the face code and size
    330     ;; should have been specified.
    331     (cond (point-size (dolist (seg segment-data)
    332                         (and (eq (cadr seg) face-code)
    333                              (= (fifth seg) point-size)
    334                              (return (setq segment seg)))))
    335           ((cdr segment-data)
    336            (ferror "Font dictionary ~A: point size not specified" filename))
    337           ((setq segment (car segment-data))))
    338     (funcall widths-file ':set-pointer (seventh segment))
    339     (let ((bc (third segment))
    340           (ec (fourth segment))
    341           line-height)
    342       (setq xwidths (make-array nil art-16b 200))
    343       (setq ywidths (make-array nil art-16b 200))
    344       (setq box-x-offset (make-array nil art-16b 200))
    345       (setq box-y-offset (make-array nil art-16b 200))
    346       (setq box-x-size (make-array nil art-16b 200))
    347       (setq box-y-size (make-array nil art-16b 200))
    348       ;; read in the widths info from the segment.
    349       (do ((i bc (1+ i))) ((> i ec))
    350         (aset (next-word) xwidths i)
    351         (next-word)
    352         (aset (next-word) ywidths i)
    353         (next-word)
    354         (aset (next-word) box-x-offset i)
    355         (aset (next-word) box-y-offset i)
    356         (aset (next-word) box-x-size i)
    357         (aset (next-word) box-y-size i))
    358       ;; Ignore the table of offsets to the raster info
    359       (do ((i bc (1+ i))) ((>i ec))
    360         (next-word))
    361       (setq fontname (string-append (code-to-name family-code)
    362                                     (format nil "~D" point-size)
    363                                     (second segment)))
    364       (setq fontname (intern (string-upcase fontname) "FONTS"))
    365       (setq fd (fed:make-font-descriptor fed:fd-name fontname))
    366       (do ((height 0)
    367            (baseline 0)
    368            (i bc (1+ i)))
    369           ((> i ec)
    370            (setq line-height (+ height baseline))
    371            (setf (fed:fd-line-spacing fd) line-height)
    372            (setf (fed:fd-blinker-height fd) line-height)
    373            (setf (fed:fd-baseline fd) baseline))
    374         (cond (( (aref box-y-size i) -1)
    375                (setq height (max height (= (aref box-x-size i) (aref box-x-offset i))))))
    376         (cond (( (aref box-y-size i) -1)
    377                (setq baseline (max baseline (- (aref box-y-offset i)))))))
    378       (do ((i bc (1+ i))
    379            (char-width)
    380            (raster-height)
    381            (raster-width)
    382            (char-baseline)
    383            (wd)
    384            (cd))
    385           ((> i ec))
    386         (cond (( (aref box-y-size i) -1)
    387                (setq char-width (aref xwidths i))
    388                (setq raster-width (aref box-x-size i))
    389                (setq raster-height (aref box-y-size i))
    390                (setq char-y-offset (aref box-y-offset i))
    391                (setq cd (fed:make-char-descriptor make-array (nil art-1b (list line-height
    392                                                                            raster-width))))
    393                (setf (cd-char-width cd) char-width)
    394                (and (= ch #\sp) (setf (fed:fd-space-width fd) char-width))
    395                (setf (cd-char-left-kern cd) (aref box-x-offset i))
    396                (aset cd fd ch)
    397                (next-word) (next-word)
    398                (dotimes (hpos raster-width)
    399                  ;; Read in the next vertical scan line.
    400                  (dotimes (vpos raster-height)
    401                   ;; If wd is exhausted, get next word into wd
    402                   (cond ((zerop (\ vpos 16.))
    403                          (setq wd (next-word))))
    404                   (setq tem (logand 1 (lsh wd (- (\ hpos 16.)))))
    405                   (as-2 tem cd
    406                         (+ vpos baseline char-y-offset)
    407                         hpos))))))
    408       (setf (fed:fd-fill-pointer fd) 200)
    409       ;; Set width of blinker and space fields from the space character.
    410       (setf (fed:fd-blinker-width fd) (fed:fd-space-width fd))
    411       (fed:font-name-set-font-and-descriptor fontname fd)
    412       fontname))
    413   (close widths-file))))
    414 );end comment
  • trunk/lisp/lmio1/serial.lisp

    r252 r288  
    1 ; -*- Mode:Lisp; Package:System-Internals -*-
    2 
    3 ; Handler for the serial I/O interface
    4 
    5 (declare (special syn1-character syn2-character dle-character ;Can't read these back
    6                   uart-registers ;3 bytes, command, mode1, mode2.
    7                   serial-unibus-channel serial-unrchf serial-error-mask))
    8 
    9 (defun make-serial-stream (&rest keywords
    10                            &aux stream (syn1-character 0) (syn2-character 0) (dle-character 0)
    11                                 (uart-registers 0)
    12                                 (serial-unibus-channel nil) (serial-unrchf nil)
    13                                 (serial-error-mask 0)
    14                                 (request-to-send t) (data-terminal-ready t)
    15                                 (synchronous-mode nil) (number-of-stop-bits 1)
    16                                 ;; Default to even parity and 7 data bits,
    17                                 ;; but don't check received parity.  This causes the
    18                                 ;; input stream to return 7-bit characters, to avoid
    19                                 ;; faking out Lisp-machine-oriented programs.
    20                                 (parity ':even) (number-of-data-bits 7)
    21                                 (baud 300.))
    22   (serial-check-existence)              ;Barf if machine doesn't have a serial I/O port
    23   (do l keywords (cddr l) (null l)
    24     (selectq (car l)
    25       (:check-parity-errors
    26         (and (cadr l) (setq serial-error-mask (logior 10 serial-error-mask))))
    27       (:check-over-run-errors
    28         (and (cadr l) (setq serial-error-mask (logior 20 serial-error-mask))))
    29       (:check-framing-errors
    30         (and (cadr l) (setq serial-error-mask (logior 40 serial-error-mask))))
    31       (:request-to-send (setq request-to-send (cadr l)))
    32       (:data-terminal-ready (setq data-terminal-ready (cadr l)))
    33       (:synchronous-mode (setq synchronous-mode (cadr l)))
    34       (:number-of-stop-bits (setq number-of-stop-bits (cadr l)))
    35       (:parity (setq parity (cadr l)))
    36       (:number-of-data-bits (setq number-of-data-bits (cadr l)))
    37       (:baud (setq baud (cadr l)))
    38       (:otherwise (ferror nil "~S unknown keyword" (car l)))))
    39   (%unibus-write 764166 20)             ;Reset
    40   (%unibus-write 764166 5)              ;Reset command register, rcv & xmt enable
    41   (serial-write-mode 60)                ;Reset modes, set to internal clocks
    42   (setq uart-registers 30005)           ;60 in mode, 5 in command
    43   (setq stream (closure '(syn1-character syn2-character dle-character uart-registers
    44                           serial-unibus-channel serial-unrchf serial-error-mask)
    45                         'serial-stream))
    46   (funcall stream ':put ':synchronous-mode synchronous-mode)
    47   (funcall stream ':put ':request-to-send request-to-send)
    48   (funcall stream ':put ':data-terminal-ready data-terminal-ready)
    49   (funcall stream ':put ':number-of-stop-bits number-of-stop-bits)
    50   (funcall stream ':put ':parity parity)
    51   (funcall stream ':put ':number-of-data-bits number-of-data-bits)
    52   (funcall stream ':put ':baud baud)
    53   (funcall stream ':clear-input)        ;Sets up the unibus channel
    54   stream)
    55 
    56 (defselect (serial-stream serial-stream-default-handler)
    57   (:tyo (char)
    58     (process-wait "Serial TYO" #'(lambda () (bit-test 1 (%unibus-read 764162))))
    59     (%unibus-write 764160 char))
    60   (:tyi (&optional ignore &aux ch status)
    61     (cond ((null serial-unrchf)
    62            (process-wait "Serial TYI" #'unibus-channel-not-empty serial-unibus-channel)
    63            (multiple-value (ch status) (read-unibus-channel serial-unibus-channel))
    64            (setq ch (logand 377 ch))
    65            (cond ((bit-test serial-error-mask status)
    66                   ;; Reset the stupid error flags
    67                   (%unibus-write 764166 (logior 20 uart-registers))
    68                   (%unibus-write 764166 uart-registers)
    69                   (cerror t nil nil
    70                           "Serial input ~:[framing ~]~:[over-run ~]~:[parity ~]error: ~O"
    71                           (zerop (logand 40 status serial-error-mask))
    72                           (zerop (logand 20 status serial-error-mask))
    73                           (zerop (logand 10 status serial-error-mask))
    74                           ch)))
    75            ch)
    76           (t (prog1 serial-unrchf (setq serial-unrchf nil)))))
    77   (:untyi (char)
    78     (setq serial-unrchf char))
    79   (:listen ()
    80            (unibus-channel-not-empty serial-unibus-channel))
    81   (:tyi-no-hang ()
    82     (and (unibus-channel-not-empty serial-unibus-channel)
    83          (serial-stream ':tyi)))
    84   (:clear-input ()              ;This fully resets the hardware.
    85     (serial-stream ':close)
    86     ;; Reset the stupid error flags
    87     (%unibus-write 764166 (logior 20 uart-registers))
    88     (%unibus-write 764166 uart-registers)
    89     (serial-write-mode (%logldb 1020 uart-registers))   ;Restore mode registers
    90     (%unibus-read 764160)       ;Flush buffered character if any
    91     (setq serial-unibus-channel (get-unibus-channel 264 764162 2 764160 2))
    92     (%unibus-write 764112 (dpb 1 0701 (%unibus-read 764112)))) ;Turn on interrupt
    93   (:close ()
    94     (%unibus-write 764112 (dpb 0 0701 (%unibus-read 764112))) ;Turn off interrupt
    95     (return-unibus-channel (prog1 serial-unibus-channel (setq serial-unibus-channel nil))))
    96   (:get . serial-get-property)
    97   (:put . serial-put-property))
    98  
    99 (defun serial-stream-default-handler (op arg1 &rest rest)
    100   (multiple-value-call (stream-default-handler #'serial-stream op arg1 rest)))
    101 
    102 ;Subroutines for use by the stream
    103 
    104 ;Read the mode register, MODE1 in high byte
    105 (defun serial-read-mode ()
    106   (%unibus-read 764166)         ;reset MODE1/MODE2 phase
    107   (dpb (%unibus-read 764164) 1010 (%unibus-read 764164)))
    108 
    109 ;Write it
    110 (defun serial-write-mode (mode)
    111   (setq uart-registers (%logdpb mode 1020 uart-registers)) ;remember it
    112   (%unibus-read 764166)         ;reset MODE1/MODE2 phase
    113   (%unibus-write 764164 (ldb 1010 mode))
    114   (%unibus-write 764164 mode))
    115 
    116 (defun serial-write-command (cmd)
    117   (setq uart-registers (dpb cmd 0010 uart-registers))  ;remember it
    118   (%unibus-write 764166 cmd))
    119 
    120 (defun serial-write-sync-chars (syn1 syn2 dle)
    121   (%unibus-read 764166)         ;reset MODE1/MODE2 phase
    122   (%unibus-write 764162 syn1)
    123   (%unibus-write 764162 syn2)
    124   (%unibus-write 764162 dle))
    125 
    126 ;Test existence of device.  If IOB not wired for it, will read back
    127 ;all zero.  If PCI not plugged in, will read back all ones.
    128 (defun serial-check-existence (&aux zeros ones)
    129   (%unibus-write 764166 0)
    130   (setq zeros (ldb 0010 (%unibus-read 764166)))
    131   (%unibus-write 764166 100)
    132   (setq ones (ldb 0010 (%unibus-read 764166)))
    133   (cond ((zerop ones) (ferror nil "This IOB does not have serial I/O"))
    134         ((= zeros 377) (ferror nil "This IOB does not contain a PCI"))))
    135 
    136 (defun serial-get-property (ignore prop)        ;:GET operation on the stream
    137     (let ((mode (serial-read-mode))
    138           (status (%unibus-read 764162))
    139           (command (%unibus-read 764166))
    140           (synchronous-p nil))
    141       (and (zerop (ldb 1002 mode)) (setq synchronous-p t))
    142       (selectq prop
    143         (:data-set-ready (bit-test 200 status)) ;This might want to be wired to CTS?
    144         (:carrier-detect (bit-test 100 status))
    145         (:request-to-send (bit-test 40 command))
    146         (:data-terminal-ready (bit-test 2 command))
    147         (:number-of-stop-bits (if synchronous-p 0
    148                                   (nth (ldb 1602 mode) '(? 1 1.5 2))))
    149         (:parity (nth (ldb 1402 mode) '(nil :odd nil :even)))
    150         (:number-of-data-bits (+ 5 (ldb 1202 mode)))
    151         (:baud (nth (ldb 0004 mode) '(50. 75. 110. 134. 150. 300. 600.
    152                                       1200. 1800. 2000. 2400. 3600.
    153                                       4800. 7200. 9600. 19200.)))
    154         (:synchronous-mode synchronous-p)
    155         (:syn1-character syn1-character)
    156         (:syn2-character syn2-character)
    157         (:dle-character dle-character)
    158         (:single-sync-char-mode (and synchronous-p (bit-test 100000 mode)))
    159         (:sync-transparent-mode (and synchronous-p (bit-test 40000 mode)))
    160         (:automatic-echo-mode (and (not synchronous-p) (= (ldb 0602 command) 1)))
    161         (:sync-dle-stripping-mode (and synchronous-p (= (ldb 0602 command) 1)))
    162         (:local-loop-back (= (ldb 0602 command) 2))
    163         (:remote-loop-back (= (ldb 0602 command) 3))
    164         (:receive-enable (bit-test 4 command))
    165         (:transmit-enable (bit-test 1 command))
    166         (:check-parity-errors (bit-test 10 serial-error-mask))
    167         (:check-over-run-errors (bit-test 20 serial-error-mask))
    168         (:check-framing-errors (bit-test 40 serial-error-mask))
    169         (:otherwise (ferror nil "~S not a valid property name" prop)))))
    170 
    171 (defun serial-put-property (ignore prop val)    ;:PUT operation on the stream
    172     (let ((mode (serial-read-mode))
    173           (command (%unibus-read 764166))
    174           (synchronous-p nil))
    175       (and (zerop (ldb 1002 mode)) (setq synchronous-p t))
    176       (selectq prop
    177         (:request-to-send (serial-write-command (logior 40 command)))
    178         (:data-terminal-ready (serial-write-command (logior 2 command)))