Changeset 288

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

Update from System 78.

Location:
trunk/lisp/lmio1
Files:
7 added
24 removed
14 modified

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 
     
    689689;RETEST BAD RUNS.  NOTE THEY ARE IN TEXT FORM 
    690690(DEFUN CTEST-RETEST-BAD-RUNS (&OPTIONAL (BAD-RUNS CTEST-BAD-RUNS)) 
     691  (SETQ CTEST-OLD-BAD-RUNS CTEST-BAD-RUNS) 
     692  (SETQ CTEST-BAD-RUNS NIL) 
    691693  (CTEST-TRY-TESTING 0 (MAPCAR (FUNCTION CTEST-UNCONVERT-RUN) 
    692694                               (MAPCAR (FUNCTION CAR) BAD-RUNS)))) 
     
    748750        (SETQ LOC-LIST (CADR RUN) SEG-NO 0) 
    749751   L    (COND ((NULL (CDR LOC-LIST)) 
    750                (RETURN (LIST (CTEST-CONVERT-RUN RUN) ANS))) 
    751               ((TEST-WIRE (LIST (CAR RUN) (SETQ SEG-NO (1+ SEG-NO))) 
     752               (RETURN (LIST (CTEST-CONVERT-RUN RUN) ANS)))) 
     753        (SETQ SEG-NO (1+ SEG-NO)) 
     754        (COND ((TEST-WIRE (CAR RUN) 
    752755                          (CAR LOC-LIST) 
    753756                          (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   ) 
     23  (PUP-SOURCE-PORT-LOW))        ;Data follow, then checksum 
    4524 
    46 ;Get a PUP buffer which can be filled in then transmitted 
    47 (DEFUN GET-PUP (DEST-HOST DEST-PORT SOURCE-PORT 
    48                 PUP-TYPE PUP-ID 
    49                 &AUX (INT-PKT (ALLOCATE-INT-PKT))) 
    50   (FILLARRAY INT-PKT '(0)) 
    51   (SETF (MUPPET-VERSION INT-PKT) 1) 
    52   (SETF (MUPPET-PROTOCOL INT-PKT) 3) 
    53   (SETF (MUPPET-DEST-HOST INT-PKT) DEST-HOST) 
    54   (SETF (MUPPET-DEST-PORT INT-PKT) (LDB 0020 DEST-PORT)) 
    55   (SETF (MUPPET-SOURCE-HOST INT-PKT) MY-ADDRESS) 
    56   (SETF (MUPPET-SOURCE-PORT INT-PKT) SOURCE-PORT) 
    57   (SETF (MUPPET-PACKET-NUMBER INT-PKT) PUP-ID) 
    58   (SETF (MUPPET-CHECKSUM INT-PKT) -1)           ;None 
    59   (SETF (PUP-TYPE INT-PKT) PUP-TYPE) 
    60   (SETF (PUP-ID-HIGH INT-PKT) (LDB 2020 PUP-ID)) 
    61   (SETF (PUP-ID-LOW INT-PKT) (LDB 0020 PUP-ID)) 
    62   (SETF (PUP-DEST-HOST INT-PKT) DEST-HOST) 
    63   (SETF (PUP-DEST-PORT-HIGH INT-PKT) (LDB 2020 DEST-PORT)) 
    64   (SETF (PUP-DEST-PORT-LOW INT-PKT) (LDB 0020 DEST-PORT)) 
    65   (SETF (PUP-SOURCE-HOST INT-PKT) MY-ADDRESS) 
    66   (SETF (PUP-SOURCE-PORT-LOW INT-PKT) SOURCE-PORT) 
    67   INT-PKT) 
     25;Get a PUP buffer which can be filled in then transmitted via TRANSMIT-PUP 
     26(DEFUN GET-PUP (CONN PUP-TYPE PUP-ID 
     27                &AUX (PKT (GET-PKT))) 
     28  (COPY-ARRAY-PORTION PKT 0 0 PKT 0 (ARRAY-LENGTH PKT)) ;Clear to zero 
     29  (SETF (PUP-TYPE PKT) PUP-TYPE) 
     30  (SETF (PUP-ID-HIGH PKT) (LDB 2020 PUP-ID)) 
     31  (SETF (PUP-ID-LOW PKT) (LDB 0020 PUP-ID)) 
     32  (SETF (PUP-DEST-HOST PKT) (FOREIGN-ADDRESS CONN)) 
     33  (SETF (PUP-DEST-PORT-HIGH PKT) (LDB 2020 (FOREIGN-INDEX-NUM CONN))) 
     34  (SETF (PUP-DEST-PORT-LOW PKT) (LDB 0020 (FOREIGN-INDEX-NUM CONN))) 
     35  (SETF (PUP-SOURCE-HOST PKT) MY-ADDRESS) 
     36  (SETF (PUP-SOURCE-PORT-LOW PKT) (LOCAL-INDEX-NUM CONN)) 
     37  PKT) 
     38 
     39;The header of a PUP is words and the data portion is bytes. 
     40;The bytes are already in Lisp machine order, but the header needs to be fixed. 
     41(DEFUN SWAB-PUP (PUP) 
     42  (LOOP FOR I FROM FIRST-DATA-WORD-IN-PKT BELOW PUP-FIRST-DATA-WORD 
     43        AS WD = (AREF PUP I) 
     44        DO (ASET (DPB WD 1010 (LDB 1010 WD)) PUP I)) 
     45  PUP) 
     46 
     47;Accessor for binary data in a PUP 
     48(DEFUN PUP-WORD (PUP I) 
     49  (LET ((WD (AREF PUP (+ PUP-FIRST-DATA-WORD I)))) 
     50    (DPB WD 1010 (LDB 1010 WD)))) 
     51 
     52(DEFPROP PUP-WORD ((PUP-WORD PUP I) . (PUP-STORE-WORD PUP I SI:VAL)) SETF) 
     53(DEFUN PUP-STORE-WORD (PUP I WD) 
     54  (ASET (DPB WD 1010 (LDB 1010 WD)) PUP (+ PUP-FIRST-DATA-WORD I))) 
    6855 
    6956;Compute the checksum of a PUP 
    70 (DEFUN CHECKSUM-PUP (INT-PKT) 
    71   (DO ((I 12. (1+ I)) 
     57(DEFUN CHECKSUM-PUP (PKT) 
     58  (DO ((I -10. (1+ I)) 
    7259       (CK 0) 
    73        (N (LSH (1- (PUP-OVERALL-LENGTH INT-PKT)) -1) (1- N))) 
     60       (N (LSH (1- (PKT-NBYTES PKT)) -1) (1- N))) 
    7461      ((ZEROP N) 
    7562       (AND (= CK 177777) (SETQ CK 0))          ;Gronk minus zero 
    7663       (RETURN CK I))                           ;Return checksum and index in PUP of cksm 
    77     (SETQ CK (+ CK (AREF INT-PKT I)))           ;1's complement add 
     64    (SETQ CK (+ CK (PUP-WORD PKT I)))           ;1's complement add 
    7865    (AND (BIT-TEST 200000 CK) (SETQ CK (LDB 0020 (1+ CK)))) 
    7966    (SETQ CK (DPB CK 0117 (LDB 1701 CK)))))     ;16-bit left rotate 
    8067 
    8168;Fire off a PUP previously gotten from GET-PUP 
    82 (DEFUN TRANSMIT-PUP (INT-PKT N-BYTES) 
    83   (SETF (MUPPET-DATA-LENGTH INT-PKT) (+ 22. N-BYTES)) 
    84   (SETF (PUP-OVERALL-LENGTH INT-PKT) (+ 22. N-BYTES)) 
    85   (MULTIPLE-VALUE-BIND (CKSM CKSMX) (CHECKSUM-PUP INT-PKT) 
    86     (ASET CKSM INT-PKT CKSMX) 
    87     (ASET (AREF ROUTING-TABLE (LDB 1010 (MUPPET-DEST-HOST INT-PKT))) INT-PKT (1+ CKSMX)) 
    88     (SETF (INT-PKT-WORD-COUNT INT-PKT) (+ CKSMX 2)) 
    89     (OR (= (%AREA-NUMBER INT-PKT) CHAOS-BUFFER-AREA) 
    90         (FERROR NIL "Attempt to transmit non-interrupt packet ~A" INT-PKT)) 
    91     (WITHOUT-INTERRUPTS                         ;Ah, modularity, wonderful modularity. 
    92      (PROG (OLD-TRANSMIT-LIST) 
    93          (SETQ PKTS-TRANSMITTED (1+ PKTS-TRANSMITTED)) 
    94       LOOP 
    95          (SETQ OLD-TRANSMIT-LIST (INT-TRANSMIT-LIST)) 
    96          (SETF (INT-PKT-THREAD INT-PKT) OLD-TRANSMIT-LIST) 
    97          (OR (%STORE-CONDITIONAL INT-TRANSMIT-LIST-POINTER OLD-TRANSMIT-LIST INT-PKT) 
    98              (GO LOOP)) 
    99          (%CHAOS-WAKEUP))))) 
     69(DEFUN TRANSMIT-PUP (CONN PKT N-BYTES) 
     70  (SETF (PKT-NBYTES PKT) (+ PUP-NON-DATA-BYTES N-BYTES)) 
     71  (SETF (PUP-OVERALL-LENGTH PKT) (+ PUP-NON-DATA-BYTES N-BYTES)) 
     72  (SETF (PKT-ACK-NUM PKT) PUP-PROTOCOL-ID) 
     73  (SWAB-PUP PKT) 
     74  (MULTIPLE-VALUE-BIND (CKSM CKSMX) (CHECKSUM-PUP PKT) 
     75    (SETF (PUP-WORD PKT CKSMX) CKSM)) 
     76  (SEND-UNC-PKT CONN PKT) 
     77  (SWAB-PUP PKT))       ;Put back in case caller retransmits it 
    10078 
    10179;Internal routine to get back a PUP on a specified port, with timeout 
    102 ;Returns INT-PKT or NIL. 
    103 (DEFUN RECEIVE-PUP (PORT &OPTIONAL (TIMEOUT 60.) 
    104                     &AUX (START-TIME (TIME)) PUP) 
    105   (UNWIND-PROTECT 
    106     (DO () ((OR PUP-INT-PKT (> (TIME-DIFFERENCE (TIME) START-TIME) TIMEOUT)) 
    107             (WITHOUT-INTERRUPTS 
    108               (SETQ PUP PUP-INT-PKT 
    109                     PUP-INT-PKT NIL)) 
    110             (AND PUP 
    111                  (MULTIPLE-VALUE-BIND (CKSM CKSMX) (CHECKSUM-PUP PUP) 
    112                    (OR (= (AREF PUP CKSMX) 177777) 
    113                        (= (AREF PUP CKSMX) CKSM) 
    114                        (PROGN (FREE-INT-PKT PUP) 
    115                               (SETQ PUP NIL))))) 
    116             PUP) 
    117       (SETQ PUP-INT-PKT-PORT PORT) 
    118       (PROCESS-WAIT "PUP in" #'(LAMBDA (START-TIME TIMEOUT) 
    119                                  (OR PUP-INT-PKT 
    120                                      (> (TIME-DIFFERENCE (TIME) START-TIME) TIMEOUT))) 
    121                              START-TIME TIMEOUT)) 
    122     (SETQ PUP-INT-PKT-PORT NIL))) 
     80;Returns PKT or NIL. 
     81(DEFUN RECEIVE-PUP (CONN &OPTIONAL (TIMEOUT 60.)) 
     82  (LOOP WITH START-TIME = (TIME) 
     83        AS PUP = (GET-NEXT-PKT CONN T) 
     84        WHEN PUP 
     85          IF (AND (= (PKT-OPCODE PUP) UNC-OP) 
     86                  (= (PKT-ACK-NUM PUP) PUP-PROTOCOL-ID) 
     87                  (MULTIPLE-VALUE-BIND (CKSM CKSMX) (CHECKSUM-PUP PUP) 
     88                    (LET ((CK (PUP-WORD PUP CKSMX))) 
     89                      (OR (= CK 177777) (= CK CKSM))))) 
     90          RETURN (SWAB-PUP PUP) 
     91          ELSE DO (RETURN-PKT PUP) 
     92        DO (PROCESS-WAIT "PUP in" 
     93                         #'(LAMBDA (CONN START-TIME TIMEOUT) 
     94                             (OR (READ-PKTS CONN) 
     95                                 (> (TIME-DIFFERENCE (TIME) START-TIME) TIMEOUT))) 
     96                         CONN START-TIME TIMEOUT) 
     97        UNTIL (> (TIME-DIFFERENCE (TIME) START-TIME) TIMEOUT))) 
    12398 
    12499;Cons a string containing characters taken from a PUP 
    125 (DEFUN PUP-STRING (PUP &OPTIONAL (FROM 0) (TO (- (PUP-OVERALL-LENGTH PUP) 22.))) 
    126   (LET ((STR (MAKE-ARRAY NIL 'ART-STRING (MAX (- TO FROM) 0)))) 
    127     (DO ((I FROM (1+ I)) 
    128          (J 0 (1+ J)) 
    129          (WD)) 
    130         (( 
    131  I TO)) 
    132       (SETQ WD (AREF PUP (+ (// I 2) 22.))) 
    133       (ASET (LDB (IF (ODDP I) 0010 1010) WD) STR J)) 
    134     STR)) 
    135  
    136 (DEFUN GET-PORT-NUMBER () 
    137   (WITHOUT-INTERRUPTS (PROG1 NEXT-LOCAL-PORT 
    138                              (SETQ NEXT-LOCAL-PORT (1+ NEXT-LOCAL-PORT)) 
    139                              (AND (> NEXT-LOCAL-PORT 177777) 
    140                                   (SETQ NEXT-LOCAL-PORT 1000))))) 
    141  
    142 ;Complain about random PUP we may have received, and free the INT-PKT 
     100(DEFUN PUP-STRING (PUP &OPTIONAL (FROM 0) (TO (- (PUP-OVERALL-LENGTH PUP) 
     101                                                 PUP-NON-DATA-BYTES))) 
     102  (SUBSTRING (PKT-STRING PUP) (+ 20. FROM) (+ 20. TO))) ;20. is bytes in pup header 
     103 
     104;Complain about random PUP we may have received, and free the PKT 
    143105;Put a trace breakpoint on this if you are trying to figure out what's going on. 
    144106(DEFUN RECEIVED-RANDOM-PUP (PUP) 
     
    150112          (DPB (PUP-SOURCE-PORT-HIGH PUP) 2020 (PUP-SOURCE-PORT-LOW PUP)) 
    151113          (= (PUP-TYPE PUP) 4)          ;Error 
    152           (AREF PUP 32.)                ;Standard code 
    153           (AREF PUP 33.)                ;Misc argument to it 
     114          (PUP-WORD PUP 10.)            ;Standard code 
     115          (PUP-WORD PUP 11.)            ;Misc argument to it 
    154116          (PUP-STRING PUP 24.))         ;Human readable text 
    155   (FREE-INT-PKT PUP) 
    156   (KBD-CHAR-AVAILABLE))                 ;Chance to hit call 
     117  (RETURN-PKT PUP)) 
    157118 
    158119;EFTP-write stream. 
    159120(DEFVAR EFTP-NEXT-PUP-ID) 
    160 (DEFVAR EFTP-FOREIGN-HOST) 
    161 (DEFVAR EFTP-FOREIGN-PORT) 
    162 (DEFVAR EFTP-LOCAL-PORT) 
     121(DEFVAR EFTP-CONN) 
    163122(DEFVAR EFTP-BINARY-P) 
    164123(DEFVAR EFTP-BUFFER) 
    165124 
    166 (DEFUN MAKE-EFTP-WRITE-STREAM (EFTP-FOREIGN-HOST 
    167                                &OPTIONAL (EFTP-BINARY-P NIL) (EFTP-FOREIGN-PORT 20)) 
     125(DEFUN MAKE-EFTP-WRITE-STREAM (FOREIGN-HOST 
     126                               &OPTIONAL (EFTP-BINARY-P NIL) (FOREIGN-PORT 20)) 
    168127  (LET ((EFTP-NEXT-PUP-ID 0) 
    169         (EFTP-LOCAL-PORT (GET-PORT-NUMBER)) 
    170         (EFTP-BUFFER (MAKE-ARRAY NIL 'ART-8B MAX-PUP-DATA-BYTES NIL '(0)))) 
    171     (CLOSURE '(EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-NEXT-PUP-ID 
    172                EFTP-LOCAL-PORT EFTP-BINARY-P EFTP-BUFFER) 
     128        (EFTP-BUFFER (MAKE-ARRAY MAX-PUP-DATA-BYTES ':TYPE 'ART-8B ':LEADER-LIST '(0))) 
     129        (EFTP-CONN (OPEN-FOREIGN-CONNECTION FOREIGN-HOST FOREIGN-PORT))) 
     130    (CLOSURE '(EFTP-NEXT-PUP-ID EFTP-CONN EFTP-BINARY-P EFTP-BUFFER) 
    173131             'EFTP-WRITE-STREAM))) 
    174132 
     
    206164                 (PUP)) 
    207165                (NIL) 
    208               (SETQ PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-LOCAL-PORT 32 ID)) 
    209               (TRANSMIT-PUP PUP 0) 
    210               (COND ((NULL (SETQ PUP (RECEIVE-PUP EFTP-LOCAL-PORT))) 
     166              (SETQ PUP (GET-PUP EFTP-CONN 32 ID)) 
     167              (TRANSMIT-PUP EFTP-CONN PUP 0) 
     168              (COND ((NULL (SETQ PUP (RECEIVE-PUP EFTP-CONN))) 
    211169                     (AND (ZEROP (\ N-RETRANSMISSIONS 10.)) 
    212170                          (FORMAT ERROR-OUTPUT 
    213                                   "~&[Host not responding to EFTP_End, still trying...]~%")) 
    214                      (KBD-CHAR-AVAILABLE)) 
     171                                  "~&[Host not responding to EFTP_End, still trying...]~%"))) 
    215172                    ((= (PUP-TYPE PUP) 33) 
    216173                     (FORMAT ERROR-OUTPUT "~&EFTP Abort in EFTP_End, code ~D, ~A~%" 
    217                              (AREF PUP 22.) (PUP-STRING PUP 2)) 
    218                      (FREE-INT-PKT PUP) 
     174                             (PUP-WORD PUP 0) (PUP-STRING PUP 2)) 
     175                     (RETURN-PKT PUP) 
    219176                     (BREAK EFTP-ABORT)) 
    220177                    ((NOT (= (PUP-TYPE PUP) 31)) 
    221178                     (RECEIVED-RANDOM-PUP PUP)) 
    222179                    ((NOT (= (DPB (PUP-ID-HIGH PUP) 2020 (PUP-ID-LOW PUP)) ID)) 
    223                      (FREE-INT-PKT PUP))                ;Ignore random old acks 
    224                     (T (FREE-INT-PKT PUP) 
     180                     (RETURN-PKT PUP))          ;Ignore random old acks 
     181                    (T (RETURN-PKT PUP)         ;Good ack 
    225182                       (RETURN NIL)))) 
    226             (TRANSMIT-PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT 
    227                                    EFTP-LOCAL-PORT 32 EFTP-NEXT-PUP-ID) 0)) 
     183            (TRANSMIT-PUP EFTP-CONN (GET-PUP EFTP-CONN 32 EFTP-NEXT-PUP-ID) 0) 
     184            (REMOVE-CONN EFTP-CONN)) 
    228185    (OTHERWISE (STREAM-DEFAULT-HANDLER #'EFTP-WRITE-STREAM OP ARG1 ARGS)))) 
    229186 
     
    234191            (PUP)) 
    235192           (NIL) 
    236          (SETQ PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-LOCAL-PORT 30 ID)) 
     193         (SETQ PUP (GET-PUP EFTP-CONN 30 ID)) 
    237194         (DOTIMES (I (// (1+ (ARRAY-ACTIVE-LENGTH EFTP-BUFFER)) 2)) 
    238            (ASET (+ (LSH (AREF EFTP-BUFFER (* I 2)) 8) (AREF EFTP-BUFFER (1+ (* I 2)))) 
    239                  PUP (+ I 22.))) 
    240          (TRANSMIT-PUP PUP (ARRAY-ACTIVE-LENGTH EFTP-BUFFER)) 
    241          (COND ((NULL (SETQ PUP (RECEIVE-PUP EFTP-LOCAL-PORT))) 
     195           (ASET (DPB (AREF EFTP-BUFFER (1+ (* I 2))) 1010 (AREF EFTP-BUFFER (* I 2))) 
     196                 PUP (+ I PUP-FIRST-DATA-WORD))) 
     197         (TRANSMIT-PUP EFTP-CONN PUP (ARRAY-ACTIVE-LENGTH EFTP-BUFFER)) 
     198         (COND ((NULL (SETQ PUP (RECEIVE-PUP EFTP-CONN))) 
    242199                (AND (ZEROP (\ N-RETRANSMISSIONS 10.)) 
    243                      (FORMAT ERROR-OUTPUT "~&[Host not responding, still trying...]~%")) 
    244                 (KBD-CHAR-AVAILABLE)) 
     200                     (FORMAT ERROR-OUTPUT "~&[Host not responding, still trying...]~%"))) 
    245201               ((= (PUP-TYPE PUP) 33) 
    246202                (FORMAT ERROR-OUTPUT "~&EFTP Abort code ~D, ~A~%" 
    247                         (AREF PUP 22.) (PUP-STRING PUP 2)) 
    248                 (FREE-INT-PKT PUP) 
     203                        (PUP-WORD PUP 0) (PUP-STRING PUP 2)) 
     204                (RETURN-PKT PUP) 
    249205                (BREAK EFTP-ABORT)) 
    250206               ((NOT (= (PUP-TYPE PUP) 31)) 
    251207                (RECEIVED-RANDOM-PUP PUP)) 
    252208               ((NOT (= (DPB (PUP-ID-HIGH PUP) 2020 (PUP-ID-LOW PUP)) ID)) 
    253                 (FREE-INT-PKT PUP))             ;Ignore random old acks 
    254                (T (FREE-INT-PKT PUP) 
     209                (RETURN-PKT PUP))               ;Ignore random old acks 
     210               (T (RETURN-PKT PUP)              ;Good ack 
    255211                  (RETURN NIL)))))              ;Bingo! 
    256212  (STORE-ARRAY-LEADER 0 EFTP-BUFFER 0) 
    257213  T) 
    258  
    259 (DEFUN EFTP-BINARY-FILE-TO-ALTO (FILENAME ALTO-ADDRESS) 
    260   (LET ((IN (GLOBAL:OPEN FILENAME '(:READ :FIXNUM :BYTE-SIZE 8))) 
    261         (OUT (MAKE-EFTP-WRITE-STREAM ALTO-ADDRESS T))) 
    262     (STREAM-COPY-UNTIL-EOF IN OUT) 
    263     (FUNCALL OUT ':CLOSE) 
    264     (FUNCALL IN ':CLOSE))) 
    265214 
    266215(DEFVAR EFTP-UNRCHF) 
    267216 
    268 (DEFUN MAKE-EFTP-READ-STREAM (EFTP-FOREIGN-HOST 
    269                                &OPTIONAL (EFTP-BINARY-P NIL) (EFTP-LOCAL-PORT 20)) 
     217(DEFUN MAKE-EFTP-READ-STREAM (FOREIGN-HOST 
     218                               &OPTIONAL (EFTP-BINARY-P NIL) (LOCAL-PORT 20)) 
    270219  (LET ((EFTP-NEXT-PUP-ID 0) 
    271         (EFTP-FOREIGN-PORT NIL) ;Set later 
     220        (EFTP-CONN (OPEN-FOREIGN-CONNECTION FOREIGN-HOST 0 10. LOCAL-PORT)) 
    272221        (EFTP-UNRCHF NIL) 
    273         (EFTP-BUFFER (MAKE-ARRAY NIL 'ART-8B MAX-PUP-DATA-BYTES NIL '(0 0)))) 
    274     (CLOSURE '(EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-UNRCHF EFTP-NEXT-PUP-ID 
    275                EFTP-LOCAL-PORT EFTP-BINARY-P EFTP-BUFFER) 
     222        (EFTP-BUFFER (MAKE-ARRAY MAX-PUP-DATA-BYTES ':TYPE 'ART-8B ':LEADER-LIST '(0 0)))) 
     223    (CLOSURE '(EFTP-CONN EFTP-UNRCHF EFTP-NEXT-PUP-ID EFTP-BINARY-P EFTP-BUFFER) 
    276224             'EFTP-READ-STREAM))) 
    277225 
    278226(DEFUN EFTP-READ-STREAM (OP &OPTIONAL ARG1 &REST ARGS) 
    279227  (SELECTQ OP 
    280     (:WHICH-OPERATIONS '(:TYI :UNTYI)) 
     228    (:WHICH-OPERATIONS '(:TYI :UNTYI :CLOSE)) 
    281229    (:TYI (COND (EFTP-UNRCHF 
    282230                  (PROG1 EFTP-UNRCHF (SETQ EFTP-UNRCHF NIL))) 
     
    290238                                  (SETQ CH (EFTP-READ-STREAM OP ARG1)))))) 
    291239                    CH)) 
    292                 ((AND EFTP-FOREIGN-HOST (EFTP-READ-NEXT-PUP)) 
     240                ((AND EFTP-CONN (EFTP-READ-NEXT-PUP)) 
    293241                  (EFTP-READ-STREAM OP ARG1)) 
    294242                (T ;Eof 
    295                   (SETQ EFTP-FOREIGN-HOST NIL)  ;Flag as eof 
     243                  (REMOVE-CONN EFTP-CONN) 
     244                  (SETQ EFTP-CONN NIL)          ;Flag as eof 
    296245                  (AND ARG1 (ERROR ARG1))))) 
    297246    (:UNTYI (SETQ EFTP-UNRCHF ARG1)) 
     247    (:CLOSE (REMOVE-CONN EFTP-CONN)) 
    298248    (OTHERWISE (STREAM-DEFAULT-HANDLER #'EFTP-READ-STREAM OP ARG1 ARGS)))) 
    299249 
     
    301251  "Returns NIL at eof, else sets up buffer" 
    302252  ;; EFTP-NEXT-PUP-ID has the number of the packet we are expecting to receive here 
    303   (AND EFTP-FOREIGN-PORT                ;Not first time, acknowledge previous packet 
    304        (TRANSMIT-PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-LOCAL-PORT 
    305                               31 (1- EFTP-NEXT-PUP-ID)) 0)) 
     253  (AND (PLUSP EFTP-NEXT-PUP-ID)         ;Not first time, acknowledge previous packet 
     254       (TRANSMIT-PUP EFTP-CONN (GET-PUP EFTP-CONN 31 (1- EFTP-NEXT-PUP-ID)) 0)) 
    306255  (DO ((N-TIMEOUTS 1 (1+ N-TIMEOUTS)) 
    307256       (EOF-SEQUENCE-P NIL) 
    308257       (PUP)) 
    309258      (NIL)                             ;Loop until receive data 
    310     (COND ((NULL (SETQ PUP (RECEIVE-PUP EFTP-LOCAL-PORT))) 
     259    (COND ((NULL (SETQ PUP (RECEIVE-PUP EFTP-CONN))) 
    311260           (COND ((ZEROP (\ N-TIMEOUTS 10.)) 
    312261                  (AND EOF-SEQUENCE-P (RETURN NIL))     ;Done with dally timeout 
    313262                  (FORMAT ERROR-OUTPUT 
    314                           (IF EFTP-FOREIGN-PORT 
     263                          (IF (PLUSP EFTP-NEXT-PUP-ID) 
    315264                              "~&[Host has stopped sending, still trying...]~%" 
    316                               "~&[Host has not started sending, still trying...]~%")))) 
    317            (KBD-CHAR-AVAILABLE)) 
     265                              "~&[Host has not started sending, still trying...]~%"))))) 
    318266          ((NOT (AND (OR (= (PUP-TYPE PUP) 30) (= (PUP-TYPE PUP) 32) (= (PUP-TYPE PUP) 33)) 
    319                      (= (PUP-SOURCE-HOST PUP) EFTP-FOREIGN-HOST) 
    320                      (OR (NULL EFTP-FOREIGN-PORT) 
     267                     (= (PUP-SOURCE-HOST PUP) (FOREIGN-ADDRESS EFTP-CONN)) 
     268                     (OR (ZEROP EFTP-NEXT-PUP-ID) 
    321269                         (= (DPB (PUP-SOURCE-PORT-HIGH PUP) 2020 (PUP-SOURCE-PORT-LOW PUP)) 
    322                             EFTP-FOREIGN-PORT)))) 
     270                            (FOREIGN-INDEX-NUM EFTP-CONN))))) 
    323271           (RECEIVED-RANDOM-PUP PUP)) 
    324272          ((= (PUP-TYPE PUP) 33) 
    325273           (FORMAT ERROR-OUTPUT "~&EFTP Abort~:[~; in eof sequence~], code ~D, ~A~%" 
    326                    EOF-SEQUENCE-P (AREF PUP 22.) (PUP-STRING PUP 2)) 
    327            (FREE-INT-PKT PUP) 
     274                   EOF-SEQUENCE-P (PUP-WORD PUP 0) (PUP-STRING PUP 2)) 
     275           (RETURN-PKT PUP) 
    328276           (BREAK EFTP-ABORT)) 
    329277          ((NOT (= (DPB (PUP-ID-HIGH PUP) 2020 (PUP-ID-LOW PUP)) 
    330278                   EFTP-NEXT-PUP-ID)) 
    331            (FREE-INT-PKT PUP)           ;Ignore random old data 
    332            (AND EFTP-FOREIGN-PORT       ;Except repeat acknowledgement 
    333                 (TRANSMIT-PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-LOCAL-PORT 
    334                                        31 (1- EFTP-NEXT-PUP-ID)) 0))) 
     279           (RETURN-PKT PUP)             ;Ignore random old data 
     280           (AND (PLUSP EFTP-NEXT-PUP-ID);Except repeat acknowledgement 
     281                (TRANSMIT-PUP EFTP-CONN (GET-PUP EFTP-CONN 31 (1- EFTP-NEXT-PUP-ID)) 0))) 
    335282          ((= (PUP-TYPE PUP) 32)        ;Eof 
    336            (FREE-INT-PKT PUP) 
     283           (RETURN-PKT PUP) 
    337284           (AND EOF-SEQUENCE-P (RETURN NIL))    ;Done dallying 
    338285           (SETQ EOF-SEQUENCE-P T)      ;Ack the EFTP-END packet 
    339            (TRANSMIT-PUP (GET-PUP EFTP-FOREIGN-HOST EFTP-FOREIGN-PORT EFTP-LOCAL-PORT 
    340                                   31 EFTP-NEXT-PUP-ID) 0) 
     286           (TRANSMIT-PUP EFTP-CONN (GET-PUP EFTP-CONN 31 EFTP-NEXT-PUP-ID) 0) 
    341287           (SETQ EFTP-NEXT-PUP-ID (1+ EFTP-NEXT-PUP-ID))) 
    342288          (T                            ;Incoming data 
    343289           (AND (> N-TIMEOUTS 9) 
    344290                (FORMAT ERROR-OUTPUT "~&[Host has commenced transmission]~%")) 
    345            (AND (NULL EFTP-FOREIGN-PORT) 
    346                 (SETQ EFTP-FOREIGN-PORT (DPB (PUP-SOURCE-PORT-HIGH PUP) 
    347                                             2020 (PUP-SOURCE-PORT-LOW PUP)))) 
     291           (AND (ZEROP EFTP-NEXT-PUP-ID) 
     292                (SETF (FOREIGN-INDEX-NUM EFTP-CONN) 
     293                      (DPB (PUP-SOURCE-PORT-HIGH PUP) 2020 (PUP-SOURCE-PORT-LOW PUP)))) 
    348294           (SETF (ARRAY-LEADER EFTP-BUFFER 1) 0) 
    349            (SETF (ARRAY-LEADER EFTP-BUFFER 0) (- (PUP-OVERALL-LENGTH PUP) 22.)) 
     295           (SETF (ARRAY-LEADER EFTP-BUFFER 0) (- (PUP-OVERALL-LENGTH PUP) PUP-NON-DATA-BYTES)) 
    350296           (DOTIMES (I (// (1+ (ARRAY-ACTIVE-LENGTH EFTP-BUFFER)) 2)) 
    351              (LET ((WD (AREF PUP (+ I 22.)))) 
    352                (ASET (LDB 1010 WD) EFTP-BUFFER (* I 2)) 
    353                (ASET (LDB 0010 WD) EFTP-BUFFER (1+ (* I 2))))) 
    354            (FREE-INT-PKT PUP) 
     297             (LET ((WD (AREF PUP (+ I PUP-FIRST-DATA-WORD)))) 
     298               (ASET (LDB 0010 WD) EFTP-BUFFER (* I 2)) 
     299               (ASET (LDB 1010 WD) EFTP-BUFFER (1+ (* I 2))))) 
     300           (RETURN-PKT PUP) 
    355301           (SETQ EFTP-NEXT-PUP-ID (1+ EFTP-NEXT-PUP-ID)) 
    356302           (RETURN T))))) 
    357303 
     304(DEFUN EFTP-BINARY-FILE-TO-ALTO (FILENAME ALTO-ADDRESS) 
     305  (WITH-OPEN-FILE (IN FILENAME '(:READ :FIXNUM :BYTE-SIZE 8)) 
     306    (LET ((OUT (MAKE-EFTP-WRITE-STREAM ALTO-ADDRESS T))) 
     307      (STREAM-COPY-UNTIL-EOF IN OUT) 
     308      (FUNCALL OUT ':CLOSE)))) 
     309 
    358310(DEFUN EFTP-BINARY-FILE-FROM-ALTO (FILENAME ALTO-ADDRESS) 
    359   (LET ((OUT (GLOBAL:OPEN FILENAME '(:WRITE :FIXNUM :BYTE-SIZE 8))) 
    360         (IN (MAKE-EFTP-READ-STREAM ALTO-ADDRESS T))) 
    361     (STREAM-COPY-UNTIL-EOF IN OUT) 
    362     (FUNCALL OUT ':CLOSE))) 
    363  
     311  (WITH-OPEN-FILE (OUT FILENAME '(:WRITE :FIXNUM :BYTE-SIZE 8)) 
     312    (LET ((IN (MAKE-EFTP-READ-STREAM ALTO-ADDRESS T))) 
     313      (STREAM-COPY-UNTIL-EOF IN OUT)))) 
    364314 
    365315(DEFUN EFTP-TEXT-FILE-FROM-ALTO (FILENAME ALTO-ADDRESS) 
    366   (LET ((OUT (GLOBAL:OPEN FILENAME '(:WRITE))) 
    367         (IN (MAKE-EFTP-READ-STREAM ALTO-ADDRESS))) 
    368     (STREAM-COPY-UNTIL-EOF IN OUT) 
    369     (FUNCALL OUT ':CLOSE))) 
     316  (WITH-OPEN-FILE (OUT FILENAME '(:WRITE)) 
     317    (LET ((IN (MAKE-EFTP-READ-STREAM ALTO-ADDRESS))) 
     318      (STREAM-COPY-UNTIL-EOF IN OUT)))) 
    370319 
    371320(DEFUN EFTP-TEXT-FILE-TO-ALTO (FILENAME ALTO-ADDRESS) 
    372   (LET ((IN (GLOBAL:OPEN FILENAME '(:READ))) 
    373         (OUT (MAKE-EFTP-WRITE-STREAM ALTO-ADDRESS))) 
    374     (STREAM-COPY-UNTIL-EOF IN OUT) 
    375     (FUNCALL IN ':CLOSE) 
    376     (FUNCALL OUT ':CLOSE))) 
     321  (WITH-OPEN-FILE (IN FILENAME '(:READ)) 
     322    (LET ((OUT (MAKE-EFTP-WRITE-STREAM ALTO-ADDRESS))) 
     323      (STREAM-COPY-UNTIL-EOF IN OUT) 
     324      (FUNCALL OUT ':CLOSE)))) 
     325 
  • 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. 
    17  
     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 
    1839;First some helping functions: 
    1940 
    2041;Maximum raster width of an FD format font 
    2142(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))))))) 
     43  (DO ((CHAR-CODE 0 (1+ CHAR-CODE)) 
     44       (FONT-LENGTH (ARRAY-ACTIVE-LENGTH FONT-DESCRIPTOR))) 
     45      (( 
     46 CHAR-CODE FONT-LENGTH) GUESS) 
     47    (COND ((SETQ TEMP (AREF FONT-DESCRIPTOR CHAR-CODE)) 
     48           (SETQ GUESS (MAX GUESS (ARRAY-DIMENSION-N 2 TEMP))))))) 
    2749 
    2850;Maximum raster height of an FD format font 
    2951(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))))))) 
     52  (DO ((CHAR-CODE 0 (1+ CHAR-CODE)) 
     53       (FONT-LENGTH (ARRAY-ACTIVE-LENGTH FONT-DESCRIPTOR))) 
     54      (( 
     55 CHAR-CODE FONT-LENGTH) GUESS) 
     56    (COND ((SETQ TEMP (AREF FONT-DESCRIPTOR CHAR-CODE)) 
     57           (SETQ GUESS (MAX GUESS (ARRAY-DIMENSION-N 1 TEMP))))))) 
    3558 
    3659;;; Memoizing version of FONT-INTO-FONT-DESCRIPTOR 
     
    3962;;; The FONT-DESCRIBED property holds the font itself which the descriptor matches. 
    4063;;; 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) 
     64(DEFUN FONT-NAME-FONT-DESCRIPTOR (FONTNAME &AUX FD) 
     65  (SETQ FD (GET FONTNAME 'FONT-DESCRIPTOR)) 
     66  (COND ((AND FD (EQ (GET FONTNAME 'FONT-DESCRIBED) (SYMEVAL FONTNAME)))) 
     67        (T (SETQ FD (FONT-INTO-FONT-DESCRIPTOR (SYMEVAL FONTNAME))) 
     68           (PUTPROP FONTNAME (SYMEVAL FONTNAME) 'FONT-DESCRIBED) 
     69           (PUTPROP FONTNAME FD 'FONT-DESCRIPTOR))) 
     70  FD) 
    4871 
    4972;;; Set a font given a font descriptor.  Keep the descriptor around. 
    5073;;; 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)) 
     74(DEFUN FONT-NAME-SET-FONT-AND-DESCRIPTOR (FONTNAME FONT-DESCRIPTOR) 
     75  (LET ((OLDFONT (AND (BOUNDP FONTNAME) (SYMEVAL FONTNAME)))) 
     76    (SET FONTNAME (FONT-DESCRIPTOR-INTO-FONT FONT-DESCRIPTOR)) 
     77    (AND OLDFONT (STRUCTURE-FORWARD OLDFONT (SYMEVAL FONTNAME))) 
     78    (PUTPROP FONTNAME FONT-DESCRIPTOR 'FONT-DESCRIPTOR) 
     79    (PUTPROP FONTNAME (SYMEVAL FONTNAME) 'FONT-DESCRIBED) 
     80    FONT-DESCRIPTOR)) 
    5881 
    5982;Store a character in a font.  Given a font and corresponding FD, both are 
     
    6184;If the CD can be stored into the existing font, that is done. 
    6285;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))))) 
     86(DEFUN FONT-NAME-STORE-CD (FONTNAME CD CHAR-CODE &AUX FONT) 
     87  (LET ((WIDTH (ARRAY-DIMENSION-N 2 CD)) 
     88        (HEIGHT (ARRAY-DIMENSION-N 1 CD)) 
     89        TEM FD) 
     90    (SETQ FD (FONT-NAME-FONT-DESCRIPTOR FONTNAME)) 
     91    (FD-STORE-CD FD CD CHAR-CODE) 
     92    (AND (= CHAR-CODE #\SP) 
     93         (SETF (FD-SPACE-WIDTH FD) (CD-CHAR-WIDTH CD))) 
     94    (COND ((OR (NOT (BOUNDP FONTNAME)) 
     95               (NULL (SETQ FONT (SYMEVAL FONTNAME))) 
     96               ( 
     97 CHAR-CODE (MAX (OR (FONT-FILL-POINTER FONT) 200) 200)) 
     98               (> WIDTH 
     99                  (COND ((SETQ TEM (FONT-INDEXING-TABLE FONT)) 
     100                         (* (FONT-RASTER-WIDTH FONT) 
     101                            (- (AREF TEM (1+ CHAR-CODE)) 
     102                               (AREF TEM CHAR-CODE)))) 
     103                        (T (FONT-RASTER-WIDTH FONT)))) 
     104               (> HEIGHT (FONT-RASTER-HEIGHT FONT))) 
     105           (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME FD)) 
     106          (T (STORE-CD-IN-FONT CD FONT CHAR-CODE NIL))))) 
     107 
     108(DEFUN FD-STORE-CD (FD CD CH) 
     109  (AND ( 
     110 CH (ARRAY-LENGTH FD)) 
     111       (ADJUST-ARRAY-SIZE FD (+ CH 100))) 
     112  (AND ( 
     113 CH (FD-FILL-POINTER FD)) 
     114       (SETF (FD-FILL-POINTER FD) (1+ CH))) 
     115  (ASET CD FD CH)) 
    82116 
    83117;Functions for referring to specified pixels of characters in an internal format font. 
     
    88122;  (SETQ ROW (- (FONT-BASELINE FONT) ROW)) 
    89123;  (AND (SETQ TEM (FONT-LEFT-KERN-TABLE FONT)) 
    90 ;       (SETQ COL (+ COL (AR-1 TEM CHAR)))) 
     124;       (SETQ COL (+ COL (AREF TEM CHAR)))) 
    91125;However it looks like this would cause more trouble than it would save. 
    92126;Attempts to reference outside of the raster return 0, or barf if storing. 
     
    95129(DEFUN FONT-GET-PIXEL (FONT CHAR ROW COL &AUX TEM (NEXTCHAR (1+ CHAR))) 
    96130  (COND ((OR (< ROW 0) 
    97              (>= ROW (FONT-RASTER-HEIGHT FONT)) 
     131             ( 
     132 ROW (FONT-RASTER-HEIGHT FONT)) 
    98133             (< COL 0) 
    99134             (COND ((SETQ TEM (FONT-INDEXING-TABLE FONT)) 
    100                     (SETQ CHAR (+ (AR-1 TEM CHAR) (// COL (FONT-RASTER-WIDTH FONT)))) 
     135                    (SETQ CHAR (+ (AREF TEM CHAR) (// COL (FONT-RASTER-WIDTH FONT)))) 
    101136                    (SETQ COL (\ COL (FONT-RASTER-WIDTH FONT))) 
    102                     (>= CHAR (AR-1 TEM NEXTCHAR))) 
    103                    ((>= COL (FONT-RASTER-WIDTH FONT))))) 
    104          0)  ;out of bounds, return 0 
     137                    ( 
     138 CHAR (AREF TEM NEXTCHAR))) 
     139                   (( 
     140 COL (FONT-RASTER-WIDTH FONT))))) 
     141         0)     ;out of bounds, return 0 
    105142        (T 
    106143         (DO ((FONT FONT (FONT-NEXT-PLANE FONT)) 
     
    109146             ((NULL FONT) PIXEL) 
    110147           (SETQ PIXEL 
    111                  (+ PIXEL (LSH (AR-1 FONT 
     148                 (+ PIXEL (LSH (AREF FONT 
    112149                                     (+ (* 32. (+ (* (FONT-WORDS-PER-CHAR FONT) CHAR) 
    113150                                                  (// ROW (FONT-RASTERS-PER-WORD FONT)))) 
     
    119156(DEFUN FONT-SET-PIXEL (PIXEL FONT CHAR ROW COL &AUX TEM (NEXTCHAR (1+ CHAR))) 
    120157  (COND ((OR (< ROW 0) 
    121              (>= ROW (FONT-RASTER-HEIGHT FONT)) 
     158             ( 
     159 ROW (FONT-RASTER-HEIGHT FONT)) 
    122160             (< COL 0) 
    123161             (COND ((SETQ TEM (FONT-INDEXING-TABLE FONT)) 
    124                     (SETQ CHAR (+ (AR-1 TEM CHAR) (// COL (FONT-RASTER-WIDTH FONT)))) 
     162                    (SETQ CHAR (+ (AREF TEM CHAR) (// COL (FONT-RASTER-WIDTH FONT)))) 
    125163                    (SETQ COL (\ COL (FONT-RASTER-WIDTH FONT))) 
    126                     (>= CHAR (AR-1 TEM NEXTCHAR))) 
    127                    ((>= COL (FONT-RASTER-WIDTH FONT))))) 
     164                    ( 
     165 CHAR (AREF TEM NEXTCHAR))) 
     166                   (( 
     167 COL (FONT-RASTER-WIDTH FONT))))) 
    128168         (FERROR NIL "Store of ~C in ~S at ~O,~O out of character bounds" CHAR FONT ROW COL)) 
    129169        (T 
     
    131171              (BIT PIXEL (LSH BIT -1))) 
    132172             ((NULL FONT) PIXEL) 
    133              (AS-1 BIT FONT 
     173             (ASET BIT FONT 
    134174                   (+ (* 32. (+ (* (FONT-WORDS-PER-CHAR FONT) CHAR) 
    135175                                (// ROW (FONT-RASTERS-PER-WORD FONT)))) 
     
    144184 
    145185(DEFUN FONT-DESCRIPTOR-INTO-FONT (FONT-DESCRIPTOR 
    146            &OPTIONAL (NBR-PLANES-OUT NIL) 
    147            &AUX (FONT-OUT NIL) 
    148                 (COL-INCR (COND ((FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR) 2) 
    149                                 (T 1))) 
    150                 (SPACE-WIDTH (OR (FD-SPACE-WIDTH FONT-DESCRIPTOR) 0)) 
    151                 (WIDTH (// SPACE-WIDTH COL-INCR)) 
    152                 (HEIGHT (FD-LINE-SPACING FONT-DESCRIPTOR)) 
    153                 (BASELINE (FD-BASELINE FONT-DESCRIPTOR)) 
    154                 (RASTER-WIDTH (// (+ (MAX-RASTER-WIDTH FONT-DESCRIPTOR) 
    155                                      (1- COL-INCR)) 
    156                                   COL-INCR)) 
    157                 (RASTER-HEIGHT (MAX-RASTER-HEIGHT FONT-DESCRIPTOR)) 
    158                 (RASTERS-PER-WORD (// 32. (MIN 32. RASTER-WIDTH))) 
    159                 (WORDS-PER-RASTER-ELEMENT (1+ (// (1- RASTER-HEIGHT) RASTERS-PER-WORD))) 
    160                 (TOTAL-RASTER-ELEMENTS 200) 
    161                 (BLINKER-WIDTH (// (FD-BLINKER-WIDTH FONT-DESCRIPTOR) COL-INCR)) 
    162                 (BLINKER-HEIGHT (FD-BLINKER-HEIGHT FONT-DESCRIPTOR)) 
    163                 (INDEXING-TABLE NIL) 
    164                 (CHARS-EXIST-TABLE (MAKE-ARRAY NIL ART-1B 200)) 
    165                 TEMP                                    ;General temporary 
    166                 ) 
    167  
     186       &OPTIONAL (NBR-PLANES-OUT NIL) 
     187       &AUX (FONT-OUT NIL) 
     188            (FONT-DESCRIPTOR-LENGTH (ARRAY-ACTIVE-LENGTH FONT-DESCRIPTOR)) 
     189            (FONT-LENGTH (MAX FONT-DESCRIPTOR-LENGTH 200)) 
     190            (COL-INCR (COND ((FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR) 2) 
     191                            (T 1))) 
     192            (SPACE-WIDTH (OR (FIX (+ (FD-SPACE-WIDTH FONT-DESCRIPTOR) 0.5)) 0)) 
     193            (WIDTH (// SPACE-WIDTH COL-INCR)) 
     194            (HEIGHT (FD-LINE-SPACING FONT-DESCRIPTOR)) 
     195            (BASELINE (FD-BASELINE FONT-DESCRIPTOR)) 
     196            (RASTER-WIDTH (// (+ (MAX-RASTER-WIDTH FONT-DESCRIPTOR) 
     197                                 (1- COL-INCR)) 
     198                              COL-INCR)) 
     199            (RASTER-HEIGHT (MAX-RASTER-HEIGHT FONT-DESCRIPTOR)) 
     200            (RASTERS-PER-WORD (// 32. (MIN 32. RASTER-WIDTH))) 
     201            (WORDS-PER-RASTER-ELEMENT (1+ (// (1- RASTER-HEIGHT) RASTERS-PER-WORD))) 
     202            (TOTAL-RASTER-ELEMENTS FONT-LENGTH) 
     203            (BLINKER-WIDTH (// (FD-BLINKER-WIDTH FONT-DESCRIPTOR) COL-INCR)) 
     204            (BLINKER-HEIGHT (FD-BLINKER-HEIGHT FONT-DESCRIPTOR)) 
     205            (INDEXING-TABLE NIL) 
     206            (CHARS-EXIST-TABLE (MAKE-ARRAY FONT-LENGTH ':TYPE 'ART-1B)) 
     207            TEMP                                ;General temporary 
     208            ) 
     209   
    168210;Set up NBR-PLANES-OUT if defaulted 
    169        (COND ((NULL NBR-PLANES-OUT) 
    170               (SETQ NBR-PLANES-OUT COL-INCR))) 
    171  
     211  (COND ((NULL NBR-PLANES-OUT) 
     212         (SETQ NBR-PLANES-OUT COL-INCR))) 
     213   
    172214;Create INDEXING-TABLE if needed 
    173        (COND ((> RASTER-WIDTH 32.) 
    174                 (SETQ INDEXING-TABLE (MAKE-ARRAY NIL 'ART-16B 201)) 
    175                 (AS-1 0 INDEXING-TABLE 0) 
    176                 (DO ((CHAR-CODE 0 (1+ CHAR-CODE))) 
    177                     (( 
    178  CHAR-CODE 200) (SETQ TOTAL-RASTER-ELEMENTS (AR-1 INDEXING-TABLE 200))) 
    179                     (SETQ TEMP (AR-1 FONT-DESCRIPTOR CHAR-CODE)) 
    180                     (AS-1 (+ (AR-1 INDEXING-TABLE CHAR-CODE) 
    181                              (COND ((NULL TEMP) 0) 
    182                                    (T (// (+ (ARRAY-DIMENSION-N 2 TEMP) 31.) 32.)))) 
    183                           INDEXING-TABLE (1+ CHAR-CODE))) 
    184                 (SETQ RASTER-WIDTH 32.))) 
    185  
     215  (COND ((> RASTER-WIDTH 32.) 
     216         (SETQ INDEXING-TABLE (MAKE-ARRAY (1+ FONT-LENGTH) ':TYPE 'ART-16B)) 
     217         (ASET 0 INDEXING-TABLE 0) 
     218         (DO ((CHAR-CODE 0 (1+ CHAR-CODE))) 
     219             (( 
     220 CHAR-CODE FONT-LENGTH) 
     221              (SETQ TOTAL-RASTER-ELEMENTS (AREF INDEXING-TABLE FONT-LENGTH))) 
     222           (SETQ TEMP (AND (< CHAR-CODE FONT-DESCRIPTOR-LENGTH) 
     223                           (AREF FONT-DESCRIPTOR CHAR-CODE))) 
     224           (ASET (+ (AREF INDEXING-TABLE CHAR-CODE) 
     225                    (COND ((NULL TEMP) 0) 
     226                          (T (// (+ (ARRAY-DIMENSION-N 2 TEMP) 31.) 32.)))) 
     227                 INDEXING-TABLE (1+ CHAR-CODE))) 
     228         (SETQ RASTER-WIDTH 32.))) 
     229   
    186230;set up all the planes of the font 
    187        (DO ((I NBR-PLANES-OUT (1- I))) 
    188            ((ZEROP I)) 
    189  
     231  (DO ((I NBR-PLANES-OUT (1- I))) 
     232      ((ZEROP I)) 
     233     
    190234;Make up a (one-plane) font and make it's next plane be the last one we made 
    191            (SETQ TEMP (TV:MAKE-FONT MAKE-ARRAY (NIL 'ART-1B 
    192                                                     (* TOTAL-RASTER-ELEMENTS 
    193                                                        WORDS-PER-RASTER-ELEMENT 32.)))) 
    194            (SETF (FONT-NEXT-PLANE TEMP) FONT-OUT) 
    195            (SETQ FONT-OUT TEMP) 
    196  
     235    (SETQ TEMP (TV:MAKE-FONT MAKE-ARRAY (:TYPE 'ART-1B 
     236                                               :LENGTH (* TOTAL-RASTER-ELEMENTS 
     237                                                          WORDS-PER-RASTER-ELEMENT 32.)))) 
     238    (SETF (FONT-NEXT-PLANE TEMP) FONT-OUT) 
     239    (SETQ FONT-OUT TEMP) 
     240     
    197241;Now set all the other fields in the leader 
    198            (SETF (FONT-NAME FONT-OUT) (FD-NAME FONT-DESCRIPTOR)) 
    199            (SETF (FONT-CHAR-WIDTH FONT-OUT) WIDTH) 
    200            (SETF (FONT-CHAR-HEIGHT FONT-OUT) HEIGHT) 
    201            (SETF (FONT-RASTER-WIDTH FONT-OUT) RASTER-WIDTH) 
    202            (SETF (FONT-RASTER-HEIGHT FONT-OUT) RASTER-HEIGHT) 
    203            (SETF (FONT-RASTERS-PER-WORD FONT-OUT) RASTERS-PER-WORD) 
    204            (SETF (FONT-WORDS-PER-CHAR FONT-OUT) WORDS-PER-RASTER-ELEMENT) 
    205            (SETF (FONT-BASELINE FONT-OUT) BASELINE) 
    206            (SETF (FONT-BLINKER-WIDTH FONT-OUT) BLINKER-WIDTH) 
    207            (SETF (FONT-BLINKER-HEIGHT FONT-OUT) BLINKER-HEIGHT) 
    208            (SETF (FONT-NAME FONT-OUT) (FD-NAME FONT-DESCRIPTOR)) 
    209            (SETF (FONT-CHARS-EXIST-TABLE FONT-OUT) CHARS-EXIST-TABLE) 
    210            (SETF (FONT-INDEXING-TABLE FONT-OUT) INDEXING-TABLE)) 
    211        (DO ((CHAR-CODE 0 (1+ CHAR-CODE))) (( 
    212  CHAR-CODE 200)) 
    213            (SETQ TEMP (AR-1 FONT-DESCRIPTOR CHAR-CODE)) 
    214            (COND (TEMP 
    215                   (STORE-CD-IN-FONT TEMP FONT-OUT CHAR-CODE 
    216                                     (FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR))))) 
    217        FONT-OUT) 
     242    (SETF (FONT-NAME FONT-OUT) (FD-NAME FONT-DESCRIPTOR)) 
     243    (SETF (FONT-CHAR-WIDTH FONT-OUT) WIDTH) 
     244    (SETF (FONT-CHAR-HEIGHT FONT-OUT) HEIGHT) 
     245    (SETF (FONT-RASTER-WIDTH FONT-OUT) RASTER-WIDTH) 
     246    (SETF (FONT-RASTER-HEIGHT FONT-OUT) RASTER-HEIGHT) 
     247    (SETF (FONT-RASTERS-PER-WORD FONT-OUT) RASTERS-PER-WORD) 
     248    (SETF (FONT-WORDS-PER-CHAR FONT-OUT) WORDS-PER-RASTER-ELEMENT) 
     249    (SETF (FONT-BASELINE FONT-OUT) BASELINE) 
     250    (SETF (FONT-BLINKER-WIDTH FONT-OUT) BLINKER-WIDTH) 
     251    (SETF (FONT-BLINKER-HEIGHT FONT-OUT) BLINKER-HEIGHT) 
     252    (SETF (FONT-NAME FONT-OUT) (FD-NAME FONT-DESCRIPTOR)) 
     253    (SETF (FONT-CHARS-EXIST-TABLE FONT-OUT) CHARS-EXIST-TABLE) 
     254    (SETF (FONT-INDEXING-TABLE FONT-OUT) INDEXING-TABLE) 
     255    (SETF (FONT-FILL-POINTER FONT-OUT) FONT-LENGTH)) 
     256  (DO ((CHAR-CODE 0 (1+ CHAR-CODE))) 
     257      (( 
     258 CHAR-CODE FONT-LENGTH)) 
     259    (SETQ TEMP (AND (< CHAR-CODE FONT-DESCRIPTOR-LENGTH) 
     260                    (AREF FONT-DESCRIPTOR CHAR-CODE))) 
     261    (COND (TEMP 
     262           (STORE-CD-IN-FONT TEMP FONT-OUT CHAR-CODE 
     263                             (FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR))))) 
     264  FONT-OUT) 
    218265 
    219266;Store the data in CD into character number CHAR-CODE of FONT. 
     
    221268;This is not recommended for users to call. 
    222269(DEFUN STORE-CD-IN-FONT (CD FONT CHAR-CODE &OPTIONAL (DOUBLE-WIDTH-P NIL) &AUX 
    223                             (WIDTH (ARRAY-DIMENSION-N 2 CD)) 
    224                             (HEIGHT (ARRAY-DIMENSION-N 1 CD)) 
    225                             (FONT-HEIGHT (FONT-RASTER-HEIGHT FONT)) 
    226                             (FONT-WIDTH (FONT-RASTER-WIDTH FONT)) 
    227                             PIXEL 
    228                             (COL-INCR (COND (DOUBLE-WIDTH-P 2) (T 1)))) 
    229     ;; Update the font's char-width-table, creating one if necessary. 
    230     (LET ((CW (// (+ (CD-CHAR-WIDTH CD) 
    231                      (1- COL-INCR)) 
    232                   COL-INCR)) 
    233           (FCW (FONT-CHAR-WIDTH FONT)) 
    234           (FCWT (FONT-CHAR-WIDTH-TABLE FONT))) 
    235         (COND (FCWT 
    236                (AS-1 CW FCWT CHAR-CODE)) 
    237               ((NOT (= CW FCW)) 
    238                (SETF (FONT-CHAR-WIDTH-TABLE FONT) 
    239                      (SETQ FCWT (MAKE-ARRAY NIL ART-8B '(200)))) 
    240                (AND DOUBLE-WIDTH-P 
    241                     (SETF (FONT-CHAR-WIDTH-TABLE (FONT-NEXT-PLANE FONT)) 
    242                           FCWT)) 
    243                (DO I 0 (1+ I) (= I 200) 
    244                   (AS-1 FCW FCWT I)) 
    245                (AS-1 CW FCWT CHAR-CODE))) 
    246         (AND (= CHAR-CODE #/ ) 
    247              (SETF (FONT-CHAR-WIDTH FONT) CW))) 
    248     ;; Update the font's left-kern table, creating one if necessary. 
    249     (LET ((CK (CD-CHAR-LEFT-KERN CD)) 
    250           (FCKT (FONT-LEFT-KERN-TABLE FONT))) 
    251         (COND (FCKT (AS-1 CK FCKT CHAR-CODE)) 
    252               ((NOT (ZEROP CK)) 
    253                (SETF (FONT-LEFT-KERN-TABLE FONT)        ;MUST BE ART-32B BECAUSE LEFT-KERN 
    254                      (SETQ FCKT (MAKE-ARRAY NIL ART-32B '(200))))  ;CAN BE NEGATIVE 
    255                (AND DOUBLE-WIDTH-P 
    256                     (SETF (FONT-LEFT-KERN-TABLE (FONT-NEXT-PLANE FONT)) 
    257                           FCKT)) 
    258                (AS-1 CK FCKT CHAR-CODE)))) 
    259     ;; Tell the font this char exists. 
    260     (ERRSET (AS-1 1 (FONT-CHARS-EXIST-TABLE FONT) CHAR-CODE) NIL) 
    261     ;; In wide fonts, the raster width depends on the character, and is a multiple of 32. 
    262     (COND ((FONT-INDEXING-TABLE FONT) 
    263            (SETQ FONT-WIDTH (* (// (+ (ARRAY-DIMENSION-N 2 CD) 31.) 32.) 32.)))) 
    264     ;; Now copy the data. 
    265     (DO ((ROW 0 (1+ ROW))) 
     270                         (FONT-LENGTH (FONT-FILL-POINTER FONT)) 
     271                         (WIDTH (ARRAY-DIMENSION-N 2 CD)) 
     272                         (HEIGHT (ARRAY-DIMENSION-N 1 CD)) 
     273                         (FONT-HEIGHT (FONT-RASTER-HEIGHT FONT)) 
     274                         (FONT-WIDTH (FONT-RASTER-WIDTH FONT)) 
     275                         PIXEL 
     276                         (COL-INCR (COND (DOUBLE-WIDTH-P 2) (T 1)))) 
     277  (OR (AND FONT-LENGTH ( 
     278 FONT-LENGTH 200)) 
     279      (SETQ FONT-LENGTH 200)) 
     280  ;; Update the font's char-width-table, creating one if necessary. 
     281  (LET ((CW (// (+ (FIX (+ (CD-CHAR-WIDTH CD) 0.5)) 
     282                   (1- COL-INCR)) 
     283                COL-INCR)) 
     284        (FCW (FONT-CHAR-WIDTH FONT)) 
     285        (FCWT (FONT-CHAR-WIDTH-TABLE FONT))) 
     286    (COND (FCWT 
     287           (ASET CW FCWT CHAR-CODE)) 
     288          ((NOT (= CW FCW)) 
     289           (SETF (FONT-CHAR-WIDTH-TABLE FONT) 
     290                 (SETQ FCWT (MAKE-ARRAY FONT-LENGTH ':TYPE 'ART-8B))) 
     291           (AND DOUBLE-WIDTH-P 
     292                (SETF (FONT-CHAR-WIDTH-TABLE (FONT-NEXT-PLANE FONT)) 
     293                      FCWT)) 
     294           (DO I 0 (1+ I) (= I FONT-LENGTH) 
     295               (ASET FCW FCWT I)) 
     296           (ASET CW FCWT CHAR-CODE))) 
     297    (AND (= CHAR-CODE #\SP) 
     298         (SETF (FONT-CHAR-WIDTH FONT) CW))) 
     299  ;; Update the font's left-kern table, creating one if necessary. 
     300  (LET ((CK (CD-CHAR-LEFT-KERN CD)) 
     301        (FCKT (FONT-LEFT-KERN-TABLE FONT))) 
     302    (COND (FCKT (ASET CK FCKT CHAR-CODE)) 
     303          ((NOT (ZEROP CK)) 
     304           (SETF (FONT-LEFT-KERN-TABLE FONT)    ;MUST BE ART-32B BECAUSE LEFT-KERN 
     305                 (SETQ FCKT (MAKE-ARRAY FONT-LENGTH ':TYPE ART-32B)))   ;CAN BE NEGATIVE 
     306           (AND DOUBLE-WIDTH-P 
     307                (SETF (FONT-LEFT-KERN-TABLE (FONT-NEXT-PLANE FONT)) 
     308                      FCKT)) 
     309           (ASET CK FCKT CHAR-CODE)))) 
     310  ;; Tell the font this char exists. 
     311  (ERRSET (ASET 1 (FONT-CHARS-EXIST-TABLE FONT) CHAR-CODE) NIL) 
     312  ;; In wide fonts, the raster width depends on the character, and is a multiple of 32. 
     313  (COND ((FONT-INDEXING-TABLE FONT) 
     314         (SETQ FONT-WIDTH (* (// (+ (ARRAY-DIMENSION-N 2 CD) 31.) 32.) 32.)))) 
     315  ;; Now copy the data. 
     316  (DO ((ROW 0 (1+ ROW)) 
     317       (ONE-BIT-FONT (NULL (FONT-NEXT-PLANE FONT))) 
     318       (RASTER-WIDTH (FONT-RASTER-WIDTH FONT))) 
     319      (( 
     320 ROW FONT-HEIGHT)) 
     321    (DO ( 
     322         ;; Count columns in font descriptor. 
     323         (COL 0 (+ COL COL-INCR)) 
     324         ;; Count columns in font. 
     325         (PIXEL-COL 0 (1+ PIXEL-COL)) 
     326         ;; for one-bit fonts this is index in font itself of start of row. 
     327         ;; For multi-bit fonts it is not used. 
     328         (NEXT-BIT-FONT-INDEX 
     329           (+ (* 32. (+ (* (FONT-WORDS-PER-CHAR FONT) 
     330                           (IF (FONT-INDEXING-TABLE FONT) 
     331                               (AREF (FONT-INDEXING-TABLE FONT) CHAR-CODE) 
     332                               CHAR-CODE)) 
     333                        (// ROW (FONT-RASTERS-PER-WORD FONT)))) 
     334              (* (FONT-RASTER-WIDTH FONT) 
     335                 (\ ROW (FONT-RASTERS-PER-WORD FONT)))) 
     336           (1+ NEXT-BIT-FONT-INDEX))) 
    266337        (( 
    267  ROW FONT-HEIGHT)) 
    268         (DO ((COL 0 (+ COL COL-INCR)) 
    269              (PIXEL-COL 0 (1+ PIXEL-COL))) 
    270             (( 
    271338 PIXEL-COL FONT-WIDTH)) 
    272             (SETQ PIXEL (COND ((OR (>= COL WIDTH) (>= ROW HEIGHT)) 0) 
    273                               (DOUBLE-WIDTH-P 
    274                                (+ (COND ((>= (1+ COL) WIDTH) 0) 
    275                                         (T (AR-2 CD ROW (1+ COL)))) 
    276                                   (* 2 (AR-2 CD ROW COL)))) 
    277                               (T (AR-2 CD ROW COL)))) 
    278             (FONT-SET-PIXEL PIXEL FONT CHAR-CODE 
    279                             ROW PIXEL-COL)))) 
     339      ;; Get pixel out of font descriptor. 
     340      ;; If font is "double width", two pixels of font descriptor 
     341      ;; are combined into one pixel for the font itself. 
     342      (SETQ PIXEL (COND ((OR ( 
     343 COL WIDTH) ( 
     344 ROW HEIGHT)) 0) 
     345                        (DOUBLE-WIDTH-P 
     346                         (+ (COND (( 
     347 (1+ COL) WIDTH) 0) 
     348                                  (T (AREF CD ROW (1+ COL)))) 
     349                            (* 2 (AREF CD ROW COL)))) 
     350                        (T (AREF CD ROW COL)))) 
     351      ;; Store pixel into font. 
     352      ;; If pixels are only one bit and chars not too wide, use a short cut. 
     353      (COND (ONE-BIT-FONT 
     354             ;; In wide font, notice when our horizontal advance 
     355             ;; carries us into the "next character" of the many characters 
     356             ;; in the font which actually represent vertical strips of one character. 
     357             (AND (ZEROP (\ PIXEL-COL RASTER-WIDTH)) 
     358                  (NOT (ZEROP PIXEL-COL)) 
     359                  (SETQ NEXT-BIT-FONT-INDEX 
     360                        (- (+ NEXT-BIT-FONT-INDEX 
     361                              (* 32. (FONT-WORDS-PER-CHAR FONT))) 
     362                           RASTER-WIDTH))) 
     363             (ASET PIXEL FONT NEXT-BIT-FONT-INDEX)) 
     364            (T 
     365             (FONT-SET-PIXEL PIXEL FONT CHAR-CODE 
     366                             ROW PIXEL-COL)))))) 
    280367 
    281368;Create an FD format font from an internal format font 
    282369 
    283370(DEFUN FONT-INTO-FONT-DESCRIPTOR (FONT &OPTIONAL (DBL-WIDTH-P NIL) 
    284                    &AUX (FONT-DESCRIPTOR (MAKE-FONT-DESCRIPTOR)) 
    285                         (LINE-SPACING (FONT-CHAR-HEIGHT FONT)) 
    286                         (RASTER-HEIGHT (FONT-RASTER-HEIGHT FONT)) 
    287                         (BASELINE (FONT-BASELINE FONT)) 
    288                         (BLINKER-HEIGHT (FONT-BLINKER-HEIGHT FONT)) 
    289                         (BLINKER-WIDTH (FONT-BLINKER-WIDTH FONT)) 
    290                         (SPACE-WIDTH (FONT-CHAR-WIDTH FONT)) 
    291                         FONT-CHARS-EXIST-TABLE 
    292                         TEMP RASTER-WIDTH CHARACTER-WIDTH LEFT-KERN PIXEL 
    293                         ) 
    294        (ERRSET (SETQ FONT-CHARS-EXIST-TABLE (FONT-CHARS-EXIST-TABLE FONT)) NIL) 
    295        (SETF (FD-NAME FONT-DESCRIPTOR) (FONT-NAME FONT)) 
    296        (SETF (FD-LINE-SPACING FONT-DESCRIPTOR) LINE-SPACING) 
    297        (SETF (FD-BASELINE FONT-DESCRIPTOR)BASELINE) 
    298        (SETF (FD-BLINKER-HEIGHT FONT-DESCRIPTOR) BLINKER-HEIGHT) 
    299        (SETF (FD-BLINKER-WIDTH FONT-DESCRIPTOR) BLINKER-WIDTH) 
    300        (SETF (FD-SPACE-WIDTH FONT-DESCRIPTOR) SPACE-WIDTH) 
    301        (SETF (FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR) DBL-WIDTH-P) 
    302        (DO ((CHAR-CODE 0 (1+ CHAR-CODE))) 
    303            (( 
    304  CHAR-CODE 200)) 
    305            (AND FONT-CHARS-EXIST-TABLE 
    306                 (ZEROP (AR-1 FONT-CHARS-EXIST-TABLE CHAR-CODE)) 
    307                 (GO SKIP-CHAR)) 
    308            (SETQ CHARACTER-WIDTH (COND ((SETQ TEMP (FONT-CHAR-WIDTH-TABLE FONT)) 
    309                                         (AR-1 TEMP CHAR-CODE)) 
    310                                        (T (FONT-CHAR-WIDTH FONT)))) 
    311            (SETQ RASTER-WIDTH 
    312                  (FONT-CHAR-MIN-RASTER-WIDTH FONT CHAR-CODE)) 
    313            (SETQ LEFT-KERN (COND ((SETQ TEMP (FONT-LEFT-KERN-TABLE FONT)) 
    314                                   (AR-1 TEMP CHAR-CODE)) 
    315                                  (T 0))) 
    316            (SETQ TEMP (MAKE-CHAR-DESCRIPTOR 
    317                                MAKE-ARRAY (NIL 'ART-4B (LIST RASTER-HEIGHT RASTER-WIDTH)) 
    318                                CD-CHAR-WIDTH CHARACTER-WIDTH 
    319                                CD-CHAR-LEFT-KERN LEFT-KERN)) 
    320            (AS-1 TEMP FONT-DESCRIPTOR CHAR-CODE) 
    321            (COND (DBL-WIDTH-P (DO ((ROW 0 (1+ ROW))) 
    322                                   (( 
     371       &AUX FONT-DESCRIPTOR 
     372            (FONT-LENGTH (FONT-FILL-POINTER FONT)) 
     373            (LINE-SPACING (FONT-CHAR-HEIGHT FONT)) 
     374            (RASTER-HEIGHT (FONT-RASTER-HEIGHT FONT)) 
     375            (BASELINE (FONT-BASELINE FONT)) 
     376            (BLINKER-HEIGHT (FONT-BLINKER-HEIGHT FONT)) 
     377            (BLINKER-WIDTH (FONT-BLINKER-WIDTH FONT)) 
     378            (SPACE-WIDTH (FONT-CHAR-WIDTH FONT)) 
     379            FONT-CHARS-EXIST-TABLE 
     380            TEMP RASTER-WIDTH CHARACTER-WIDTH LEFT-KERN PIXEL 
     381            ) 
     382  (ERRSET (SETQ FONT-CHARS-EXIST-TABLE (FONT-CHARS-EXIST-TABLE FONT)) NIL) 
     383  ;; Correct for old fonts that may not have valid fill pointers. 
     384  (OR (AND FONT-LENGTH ( 
     385 FONT-LENGTH 200)) 
     386      (SETQ FONT-LENGTH 200)) 
     387  (SETQ FONT-DESCRIPTOR (MAKE-FONT-DESCRIPTOR MAKE-ARRAY (:LENGTH FONT-LENGTH) 
     388                                              FD-FILL-POINTER FONT-LENGTH)) 
     389  (SETF (FD-NAME FONT-DESCRIPTOR) (FONT-NAME FONT)) 
     390  (SETF (FD-LINE-SPACING FONT-DESCRIPTOR) LINE-SPACING) 
     391  (SETF (FD-BASELINE FONT-DESCRIPTOR)BASELINE) 
     392  (SETF (FD-BLINKER-HEIGHT FONT-DESCRIPTOR) BLINKER-HEIGHT) 
     393  (SETF (FD-BLINKER-WIDTH FONT-DESCRIPTOR) BLINKER-WIDTH) 
     394  (SETF (FD-SPACE-WIDTH FONT-DESCRIPTOR) SPACE-WIDTH) 
     395  (SETF (FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR) DBL-WIDTH-P) 
     396  (DO ((CHAR-CODE 0 (1+ CHAR-CODE))) 
     397      (( 
     398 CHAR-CODE FONT-LENGTH)) 
     399    (AND FONT-CHARS-EXIST-TABLE 
     400         (ZEROP (AREF FONT-CHARS-EXIST-TABLE CHAR-CODE)) 
     401         (GO SKIP-CHAR)) 
     402    (SETQ CHARACTER-WIDTH (COND ((SETQ TEMP (FONT-CHAR-WIDTH-TABLE FONT)) 
     403                                 (AREF TEMP CHAR-CODE)) 
     404                                (T (FONT-CHAR-WIDTH FONT)))) 
     405    (SETQ RASTER-WIDTH 
     406          (FONT-CHAR-MIN-RASTER-WIDTH FONT CHAR-CODE)) 
     407    ;; If we don't know for sure which chars exist, 
     408    ;; discard chars containing no information. 
     409    (AND (NULL FONT-CHARS-EXIST-TABLE) 
     410         (ZEROP RASTER-WIDTH) 
     411         ( CHAR-CODE #\SPACE) 
     412         (= CHARACTER-WIDTH (FONT-CHAR-WIDTH FONT)) 
     413         (GO SKIP-CHAR)) 
     414    (SETQ LEFT-KERN (COND ((SETQ TEMP (FONT-LEFT-KERN-TABLE FONT)) 
     415                           (AREF TEMP CHAR-CODE)) 
     416                          (T 0))) 
     417    (SETQ TEMP (MAKE-CHAR-DESCRIPTOR 
     418                 MAKE-ARRAY (:TYPE 'ART-4B 
     419                                   :LENGTH (LIST RASTER-HEIGHT RASTER-WIDTH)) 
     420                 CD-CHAR-WIDTH CHARACTER-WIDTH 
     421                 CD-CHAR-LEFT-KERN LEFT-KERN)) 
     422    (ASET TEMP FONT-DESCRIPTOR CHAR-CODE) 
     423    (COND (DBL-WIDTH-P (DO ((ROW 0 (1+ ROW))) 
     424                           (( 
    323425 ROW RASTER-HEIGHT)) 
    324                                   (DO ((COLI 0 (1+ COLI)) 
    325                                        (COL 0 (+ 2 COL))) 
    326                                       (( 
     426                        (DO ((COLI 0 (1+ COLI)) 
     427                              (COL 0 (+ 2 COL))) 
     428                             (( 
    327429 COL RASTER-WIDTH)) 
    328                                       (SETQ PIXEL (FONT-GET-PIXEL FONT CHAR-CODE ROW COLI)) 
    329                                       (AS-2 PIXEL TEMP ROW COL) 
    330                                       (AS-2 (LSH PIXEL -1) TEMP ROW (1+ COL))))) 
    331                  (T (DO ((ROW 0 (1+ ROW))) 
    332                         (( 
     430                           (SETQ PIXEL (FONT-GET-PIXEL FONT CHAR-CODE ROW COLI)) 
     431                           (ASET PIXEL TEMP ROW COL) 
     432                           (ASET (LSH PIXEL -1) TEMP ROW (1+ COL))))) 
     433          (T (DO ((ROW 0 (1+ ROW))) 
     434                (( 
    333435 ROW RASTER-HEIGHT)) 
    334                         (DO ((COL 0 (1+ COL))) 
    335                             (( 
     436               (DO ((COL 0 (1+ COL))) 
     437                   (( 
    336438 COL RASTER-WIDTH)) 
    337                             (AS-2 (FONT-GET-PIXEL FONT CHAR-CODE ROW COL) 
    338                                   TEMP ROW COL))))) 
    339            SKIP-CHAR) 
    340        FONT-DESCRIPTOR) 
     439                 (ASET (FONT-GET-PIXEL FONT CHAR-CODE ROW COL) 
     440                       TEMP ROW COL))))) 
     441    SKIP-CHAR) 
     442  FONT-DESCRIPTOR) 
    341443 
     444;; Given filename and fontname from filename &optional fontname, canonicalize them 
     445(DEFUN GET-INPUT-FILENAME-AND-FONTNAME (FILENAME FONTNAME FILE-TYPE) 
     446  (DECLARE (RETURN-LIST FILENAME FONTNAME)) 
     447  (SETQ FILENAME (FS:MERGE-PATHNAME-DEFAULTS FILENAME (PATHNAME-DEFAULTS) FILE-TYPE)) 
     448  (OR FONTNAME (SETQ FONTNAME (FUNCALL FILENAME ':NAME))) 
     449  (AND (STRINGP FONTNAME) (SETQ FONTNAME (INTERN (STRING-UPCASE FONTNAME) "FONTS"))) 
     450  (VALUES FILENAME FONTNAME)) 
     451 
    342452;; Read in a kst file and make and return a FONT-DESCRIPTOR, 
    343453;; which is an alternate convenient representation for a font. 
    344 (defun read-kst-into-font-descriptor (filename &optional fontname &aux stream fd) 
    345   (setq filename (fs:file-parse-name filename nil t ':kst)) 
    346   (or fontname (setq fontname (funcall filename ':name))) 
    347   (and (stringp fontname) (setq fontname (intern fontname "FONTS"))) 
    348   (setq stream (open filename '(:fixnum :in :byte-size 9.))) 
    349   (setq fd (make-font-descriptor fd-name fontname)) 
    350   ;; Discard KSTID. 
    351   (dotimes (i 4) (funcall stream ':tyi)) 
    352   ;; Discard column position adjust until I find out what it means. 
    353   (or (zerop (funcall stream ':tyi)) 
    354       (ferror nil 
    355               "Nonzero column-position-adjust in font ~A -- what does that mean?" 
    356               fontname)) 
    357   (setf (fd-space-width fd) 0)                  ;Just in case no space character. 
    358   (setf (fd-baseline fd) (funcall stream ':tyi)) 
    359   (setf (fd-line-spacing fd) (read-kst-halfword stream)) 
    360   (setf (fd-blinker-height fd) 
    361         (fd-line-spacing fd)) 
    362   (setf (fd-name fd) fontname) 
    363   (let (kern char-code raster-width char-width byte-list byte-list-head cd tem 
    364              (line-height (fd-line-spacing fd))) 
    365     (do () ((= (logand (read-kst-halfword stream) (read-kst-halfword stream)) -1)) 
    366       (setq kern (read-kst-halfword stream)) 
    367       (setq char-code (read-kst-halfword stream)) 
    368       (setq raster-width (read-kst-halfword stream)) 
    369       (setq char-width (read-kst-halfword stream)) 
    370       (setq cd (make-char-descriptor 
    371                  make-array (nil art-1b (list line-height raster-width)))) 
    372       (setf (cd-char-width cd) char-width) 
    373       (setf (cd-char-left-kern cd) kern) 
    374       (as-1 cd fd char-code) 
    375       (and (= char-code #/ ) 
    376            (setf (fd-space-width fd) char-width)) 
    377       ;; read in the bits of the character 
    378       (setq byte-list nil 
    379             byte-list-head (list nil nil nil nil)) 
    380       (dotimes (vpos line-height) 
    381         ;; Read in the next row. 
    382         (dotimes (hpos raster-width) 
    383           ;; If byte is exhausted, get next byte into (car byte-list) 
    384           (cond ((zerop (\ hpos 8)) 
    385                  (setq byte-list (read-kst-bytes stream byte-list byte-list-head)))) 
    386           (setq tem (logand 1 (lsh (car byte-list) (- (\ hpos 8))))) 
    387           (as-2 tem cd vpos hpos))))) 
    388   (setf (fd-fill-pointer fd) 200) 
    389   ;; Set width of blinker and space fields from the space character. 
    390   (setf (fd-blinker-width fd) 
    391         (fd-space-width fd)) 
    392   (funcall stream ':close) 
    393   fd) 
     454(DEFUN READ-KST-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME &AUX FD) 
     455  (MULTIPLE-VALUE (FILENAME FONTNAME) 
     456    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "KST")) 
     457  (WITH-OPEN-FILE (STREAM FILENAME '(:FIXNUM :IN :BYTE-SIZE 9.)) 
     458    (SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME MAKE-ARRAY (:LENGTH 200))) 
     459    ;; Discard KSTID. 
     460    (DOTIMES (I 4) (FUNCALL STREAM ':TYI)) 
     461    ;; Discard column position adjust until I find out what it means. 
     462    (OR (ZEROP (FUNCALL STREAM ':TYI)) 
     463        (FERROR NIL 
     464                "Nonzero column-position-adjust in font ~A -- what does that mean?" 
     465                FONTNAME)) 
     466    (SETF (FD-SPACE-WIDTH FD) 0)                ;Just in case no space character. 
     467    (SETF (FD-BASELINE FD) (FUNCALL STREAM ':TYI)) 
     468    (SETF (FD-LINE-SPACING FD) (READ-KST-HALFWORD STREAM)) 
     469    (SETF (FD-BLINKER-HEIGHT FD) 
     470          (FD-LINE-SPACING FD)) 
     471    (SETF (FD-NAME FD) FONTNAME) 
     472    (LET (KERN CHAR-CODE RASTER-WIDTH CHAR-WIDTH BYTE-LIST BYTE-LIST-HEAD CD TEM 
     473          (LINE-HEIGHT (FD-LINE-SPACING FD))) 
     474      (LOOP AS HEADER = (LOGIOR (ASH (READ-KST-HALFWORD STREAM) 18.) 
     475                                (READ-KST-HALFWORD STREAM)) 
     476            UNTIL (= HEADER -1) 
     477            UNLESS (= HEADER 1) 
     478              DO (FERROR NIL "~O where character header expected; KST file misformatted" 
     479                             HEADER) 
     480        DO 
     481        (SETQ KERN (READ-KST-HALFWORD STREAM)) 
     482        (SETQ CHAR-CODE (READ-KST-HALFWORD STREAM)) 
     483        (SETQ RASTER-WIDTH (READ-KST-HALFWORD STREAM)) 
     484        (SETQ CHAR-WIDTH (READ-KST-HALFWORD STREAM)) 
     485        (SETQ CD (MAKE-CHAR-DESCRIPTOR 
     486                   MAKE-ARRAY (:TYPE ART-1B :LENGTH (LIST LINE-HEIGHT RASTER-WIDTH)))) 
     487        (SETF (CD-CHAR-WIDTH CD) CHAR-WIDTH) 
     488        (SETF (CD-CHAR-LEFT-KERN CD) KERN) 
     489        (FD-STORE-CD FD CD CHAR-CODE) 
     490        (AND (= CHAR-CODE #\SP) 
     491             (SETF (FD-SPACE-WIDTH FD) CHAR-WIDTH)) 
     492        ;; read in the bits of the character 
     493        (SETQ BYTE-LIST NIL 
     494              BYTE-LIST-HEAD (LIST NIL NIL NIL NIL)) 
     495        (DOTIMES (VPOS LINE-HEIGHT) 
     496          ;; Read in the next row. 
     497          (DOTIMES (HPOS RASTER-WIDTH) 
     498            ;; If byte is exhausted, get next byte into (car byte-list) 
     499            (COND ((ZEROP (\ HPOS 8)) 
     500                   (SETQ BYTE-LIST (READ-KST-BYTES STREAM BYTE-LIST BYTE-LIST-HEAD)))) 
     501            (SETQ TEM (LOGAND 1 (LSH (CAR BYTE-LIST) (- (\ HPOS 8))))) 
     502            (ASET TEM CD VPOS HPOS))))) 
     503    ;; Truncate fd to discard unused elements at the end. 
     504    (DO ((I (1- (ARRAY-LENGTH FD)) (1- I))) 
     505        ((OR (MINUSP I) 
     506             (AREF FD I)) 
     507         (ADJUST-ARRAY-SIZE FD (1+ I)))) 
     508    (SETF (FD-FILL-POINTER FD) (ARRAY-LENGTH FD)) 
     509    ;; Set width of blinker and space fields from the space character. 
     510    (SETF (FD-BLINKER-WIDTH FD) 
     511          (FD-SPACE-WIDTH FD))) 
     512  FD) 
    394513 
    395514;; Read in a kst file and define a font. 
    396515;; The font name defaults from the file name. 
    397 (defun read-kst-into-font (filename &optional fontname 
    398                                     &aux stream font chars-exist-table 
    399                                     raster-width raster-height 
    400                                     rasters-per-word words-per-char) 
    401     (setq filename (fs:file-parse-name filename nil t ':kst)) 
    402     (or fontname (setq fontname (funcall filename ':name))) 
    403     (and (stringp fontname) (setq fontname (intern fontname "FONTS"))) 
    404     ;; Read file once to determine font parameters. 
    405     (multiple-value (raster-width raster-height) 
    406                     (read-kst-max-raster-width filename)) 
    407     ;; If this is a hairy wide font, then instead of writing it directly 
    408     ;; make a font-descriptor and turn it into a font. 
    409     (cond ((> raster-width 32.) 
    410            (font-name-set-font-and-descriptor 
    411                fontname 
    412                (read-kst-into-font-descriptor filename fontname)) 
    413            fontname) 
    414           (t 
    415            (setq rasters-per-word (// 32. raster-width)) 
    416            (setq words-per-char (// (+ raster-height rasters-per-word -1) rasters-per-word)) 
    417            ;; Now that we know the parameters, allocate the font. 
    418            (setq font (tv:make-font make-array (nil art-1b (* words-per-char 32. 200)))) 
    419            (setf (font-rasters-per-word font) rasters-per-word) 
    420            (setf (font-words-per-char font) words-per-char) 
    421            (setf (font-raster-width font) raster-width) 
    422            (setf (font-raster-height font) raster-height) 
    423            (setf (font-char-height font) raster-height) 
    424            (setf (font-blinker-height font) raster-height) 
    425            (setf (font-name font) fontname) 
    426            (setq chars-exist-table (make-array nil art-1b 200)) 
    427            (setf (font-chars-exist-table font) chars-exist-table) 
    428            ;; Now actually read in the data of the font. 
    429            (setq stream (open filename '(:fixnum :in :byte-size 9.))) 
     516;;;??? This still assumes that the font length is no more than 200! 
     517;;; It seems hard to fix this. 
     518(DEFUN READ-KST-INTO-FONT (FILENAME &OPTIONAL FONTNAME 
     519                                    &AUX FONT CHARS-EXIST-TABLE 
     520                                         RASTER-WIDTH RASTER-HEIGHT 
     521                                         RASTERS-PER-WORD WORDS-PER-CHAR) 
     522  (MULTIPLE-VALUE (FILENAME FONTNAME) 
     523    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "KST")) 
     524  ;; Read file once to determine font parameters. 
     525  (MULTIPLE-VALUE (RASTER-WIDTH RASTER-HEIGHT) 
     526    (READ-KST-MAX-RASTER-WIDTH FILENAME)) 
     527  ;; If this is a hairy wide font, then instead of writing it directly 
     528  ;; make a font-descriptor and turn it into a font. 
     529  (COND ((> RASTER-WIDTH 32.) 
     530         (FONT-NAME-SET-FONT-AND-DESCRIPTOR 
     531           FONTNAME 
     532           (READ-KST-INTO-FONT-DESCRIPTOR FILENAME FONTNAME)) 
     533         FONTNAME) 
     534        (T 
     535         (SETQ RASTERS-PER-WORD (// 32. RASTER-WIDTH)) 
     536         (SETQ WORDS-PER-CHAR (// (+ RASTER-HEIGHT RASTERS-PER-WORD -1) RASTERS-PER-WORD)) 
     537         ;; Now that we know the parameters, allocate the font. 
     538         (SETQ FONT (TV:MAKE-FONT MAKE-ARRAY (:TYPE 'ART-1B 
     539                                                    :LENGTH (* WORDS-PER-CHAR 32. 200)))) 
     540         (SETF (FONT-RASTERS-PER-WORD FONT) RASTERS-PER-WORD) 
     541         (SETF (FONT-WORDS-PER-CHAR FONT) WORDS-PER-CHAR) 
     542         (SETF (FONT-RASTER-WIDTH FONT) RASTER-WIDTH) 
     543         (SETF (FONT-RASTER-HEIGHT FONT) RASTER-HEIGHT) 
     544         (SETF (FONT-CHAR-HEIGHT FONT) RASTER-HEIGHT) 
     545         (SETF (FONT-BLINKER-HEIGHT FONT) RASTER-HEIGHT) 
     546         (SETF (FONT-NAME FONT) FONTNAME) 
     547         (SETQ CHARS-EXIST-TABLE (MAKE-ARRAY 200 ':TYPE 'ART-1B)) 
     548         (SETF (FONT-CHARS-EXIST-TABLE FONT) CHARS-EXIST-TABLE) 
     549         ;; Now actually read in the data of the font. 
     550         (WITH-OPEN-FILE (STREAM FILENAME '(:FIXNUM :IN :BYTE-SIZE 9.)) 
    430551           ;; Discard KSTID. 
    431            (dotimes (i 4) (funcall stream ':tyi)) 
     552           (DOTIMES (I 4) (FUNCALL STREAM ':TYI)) 
    432553           ;; Discard column position adjust until I find out what it means. 
    433            (or (zerop (funcall stream ':tyi)) 
    434                (ferror nil 
     554           (OR (ZEROP (FUNCALL STREAM ':TYI)) 
     555               (FERROR NIL 
    435556                       "Nonzero column-position-adjust in font ~A -- what does that mean?" 
    436                        fontname)) 
    437            (setf (font-baseline font) (funcall stream ':tyi)) 
     557                       FONTNAME)) 
     558           (SETF (FONT-BASELINE FONT) (FUNCALL STREAM ':TYI)) 
    438559           ;; Discard line height (already determined). 
    439            (read-kst-halfword stream) 
    440            (let (kern char-code char-width char-raster-width 
    441                       byte-list byte-list-head tem bit-pos word-pos 
    442                       (line-height raster-height)) 
    443                (do () ((= (logand (read-kst-halfword stream) (read-kst-halfword stream)) -1)) 
    444                    (setq kern (read-kst-halfword stream)) 
    445                    (setq char-code (read-kst-halfword stream)) 
    446                    ;; While all chars have the same raster width in the lisp machine font, 
    447                    ;; we need the raster width stored in the kst file to read the kst file. 
    448                    (setq char-raster-width (read-kst-halfword stream)) 
    449                    (setq char-width (read-kst-halfword stream)) 
    450                    (as-1 1 chars-exist-table char-code) 
    451                    ;; Now store the char width and left kern, creating the tables if nec. 
    452                    (cond ((null (font-char-width font)) 
    453                           (setf (font-char-width font) char-width)) 
    454                          ((font-char-width-table font) 
    455                           (as-1 char-width (font-char-width-table font) char-code)) 
    456                          ((= char-width (font-char-width font))) 
    457                          (t (setf (font-char-width-table font) 
    458                                   (make-array nil art-16b 200)) 
    459                             (as-1 char-width (font-char-width-table font) char-code))) 
    460                    (and (= char-code #/ ) 
    461                         (setf (font-char-width font) char-width)) 
    462                    (cond ((not (zerop kern)) 
    463                           (or (font-left-kern-table font) 
    464                               (setf (font-left-kern-table font) 
    465                                     ;; Use art-32b so can hold both signs. 
    466                                     (make-array nil art-32b 200))) 
    467                           (as-1 kern (font-left-kern-table font) char-code))) 
    468                    ;; read in the bits of the character 
    469                    (setq byte-list nil 
    470                          byte-list-head (list nil nil nil nil)) 
    471                    (setq word-pos (* char-code words-per-char) 
    472                          bit-pos 0) 
    473                    (dotimes (vpos line-height) 
    474                       ;; Find next row in font - advance to word boundary if nec. 
    475                       (and (> (+ bit-pos raster-width) 32.) 
    476                            (setq bit-pos 0 word-pos (1+ word-pos))) 
    477                       ;; Read in that row. 
    478                       (dotimes (hpos char-raster-width) 
    479                          ;; If byte is exhausted, get next byte into (car byte-list) 
    480                          (cond ((zerop (\ hpos 8)) 
    481                                 (setq byte-list (read-kst-bytes stream byte-list byte-list-head)))) 
    482                          (setq tem (logand 1 (lsh (car byte-list) (- (\ hpos 8))))) 
    483                          (as-1 tem font (+ (lsh word-pos 5) bit-pos hpos))) 
    484                       ;; Advance past this row in the font. 
    485                       (setq bit-pos (+ bit-pos raster-width))) 
    486                    )) 
    487            ;; Set width of blinker and space fields from the space character. 
    488            (setf (font-blinker-width font) 
    489                  (font-char-width font)) 
    490            (set fontname font) 
    491            (putprop fontname filename 'kst-file) 
    492            (funcall stream ':close) 
    493            fontname))) 
     560           (READ-KST-HALFWORD STREAM) 
     561           (LET (KERN CHAR-CODE CHAR-WIDTH CHAR-RASTER-WIDTH 
     562                 BYTE-LIST BYTE-LIST-HEAD TEM BIT-POS WORD-POS 
     563                 (LINE-HEIGHT RASTER-HEIGHT)) 
     564             (LOOP AS HEADER = (LOGIOR (ASH (READ-KST-HALFWORD STREAM) 18.) 
     565                                       (READ-KST-HALFWORD STREAM)) 
     566                   UNTIL (= HEADER -1) 
     567                   UNLESS (= HEADER 1) 
     568                     DO (FERROR NIL 
     569                                "~O where character header expected; KST file misformatted" 
     570                                HEADER) 
     571               DO 
     572               (SETQ KERN (READ-KST-HALFWORD STREAM)) 
     573               (SETQ CHAR-CODE (READ-KST-HALFWORD STREAM)) 
     574               ;; While all chars have the same raster width in the lisp machine font, 
     575               ;; we need the raster width stored in the kst file to read the kst file. 
     576               (SETQ CHAR-RASTER-WIDTH (READ-KST-HALFWORD STREAM)) 
     577               (SETQ CHAR-WIDTH (READ-KST-HALFWORD STREAM)) 
     578               (ASET 1 CHARS-EXIST-TABLE CHAR-CODE) 
     579               ;; Now store the char width and left kern, creating the tables if nec. 
     580               (COND ((NULL (FONT-CHAR-WIDTH FONT)) 
     581                      (SETF (FONT-CHAR-WIDTH FONT) CHAR-WIDTH)) 
     582                     ((FONT-CHAR-WIDTH-TABLE FONT) 
     583                      (ASET CHAR-WIDTH (FONT-CHAR-WIDTH-TABLE FONT) CHAR-CODE)) 
     584                     ((= CHAR-WIDTH (FONT-CHAR-WIDTH FONT))) 
     585                     (T (SETF (FONT-CHAR-WIDTH-TABLE FONT) 
     586                              (MAKE-ARRAY 200 ':TYPE 'ART-16B)) 
     587                        (ASET CHAR-WIDTH (FONT-CHAR-WIDTH-TABLE FONT) CHAR-CODE))) 
     588               (AND (= CHAR-CODE #\SP) 
     589                    (SETF (FONT-CHAR-WIDTH FONT) CHAR-WIDTH)) 
     590               (COND ((NOT (ZEROP KERN)) 
     591                      (OR (FONT-LEFT-KERN-TABLE FONT) 
     592                          (SETF (FONT-LEFT-KERN-TABLE FONT) 
     593                                ;; Use art-32b so can hold both signs. 
     594                                (MAKE-ARRAY 200 ':TYPE 'ART-32B))) 
     595                      (ASET KERN (FONT-LEFT-KERN-TABLE FONT) CHAR-CODE))) 
     596               ;; read in the bits of the character 
     597               (SETQ BYTE-LIST NIL 
     598                     BYTE-LIST-HEAD (LIST NIL NIL NIL NIL)) 
     599               (SETQ WORD-POS (* CHAR-CODE WORDS-PER-CHAR) 
     600                     BIT-POS 0) 
     601               (DOTIMES (VPOS LINE-HEIGHT) 
     602                 ;; Find next row in font - advance to word boundary if nec. 
     603                 (AND (> (+ BIT-POS RASTER-WIDTH) 32.) 
     604                      (SETQ BIT-POS 0 WORD-POS (1+ WORD-POS))) 
     605                 ;; Read in that row. 
     606                 (DOTIMES (HPOS CHAR-RASTER-WIDTH) 
     607                   ;; If byte is exhausted, get next byte into (car byte-list) 
     608                   (COND ((ZEROP (\ HPOS 8)) 
     609                          (SETQ BYTE-LIST (READ-KST-BYTES STREAM BYTE-LIST 
     610                                                          BYTE-LIST-HEAD)))) 
     611                   (SETQ TEM (LOGAND 1 (LSH (CAR BYTE-LIST) (- (\ HPOS 8))))) 
     612                   (ASET TEM FONT (+ (LSH WORD-POS 5) BIT-POS HPOS))) 
     613                 ;; Advance past this row in the font. 
     614                 (SETQ BIT-POS (+ BIT-POS RASTER-WIDTH))) 
     615               ))) 
     616         ;; Set width of blinker and space fields from the space character. 
     617         (SETF (FONT-BLINKER-WIDTH FONT) 
     618               (FONT-CHAR-WIDTH FONT)) 
     619         (SET FONTNAME FONT) 
     620         (PUTPROP FONTNAME FILENAME 'KST-FILE) 
     621         FONTNAME))) 
    494622 
    495623;; Scan a kst file and return two values which are the 
    496624;; raster width and raster height needed in a TV format font to contain that font. 
    497 (defun read-kst-max-raster-width (filename &aux stream 
    498                                                 raster-height (raster-width 0) 
    499                                                 char-raster-width) 
    500   (setq stream (open (fs:file-parse-name filename nil t ':kst) '(:fixnum :in :byte-size 9.))) 
    501   ;; Discard KSTID. 
    502   (dotimes (i 4) (funcall stream ':tyi)) 
    503   ;; Discard column-position-adjust 
    504   (funcall stream ':tyi) 
    505   ;; Discard baseline. 
    506   (funcall stream ':tyi) 
    507   ;; Remember font line height as raster height. 
    508   (setq raster-height (read-kst-halfword stream)) 
    509   ;; Keep maxing raster widths of characters into raster-width 
    510   (setq raster-width 0) 
    511   (do () ((= (logand (read-kst-halfword stream) (read-kst-halfword stream)) -1)) 
    512     ;; Ignore char's left kern. 
    513     (read-kst-halfword stream) 
    514     ;; Ignore its character code. 
    515     (read-kst-halfword stream) 
    516     ;; Max in its raster width 
    517     (setq char-raster-width (read-kst-halfword stream)) 
    518     (setq raster-width (max raster-width char-raster-width)) 
    519     ;; Ignore its character width. 
    520     (read-kst-halfword stream) 
    521     ;; Skip the bits of the character 
    522     (prog ((bytes (* raster-height (// (+ char-raster-width 7) 8)))) 
    523           (setq bytes (* 4 (// (+ bytes 3) 4))) 
    524           (dotimes (i bytes) 
    525             (funcall stream ':tyi)))) 
    526   (funcall stream ':close) 
    527   (prog () (return raster-width raster-height))) 
     625(DEFUN READ-KST-MAX-RASTER-WIDTH (FILENAME &AUX RASTER-HEIGHT (RASTER-WIDTH 0) 
     626                                                CHAR-RASTER-WIDTH) 
     627  (SETQ FILENAME (FS:MERGE-PATHNAME-DEFAULTS FILENAME (PATHNAME-DEFAULTS) "KST")) 
     628  (WITH-OPEN-FILE (STREAM FILENAME '(:FIXNUM :IN :BYTE-SIZE 9.)) 
     629    ;; Discard KSTID. 
     630    (DOTIMES (I 4) (FUNCALL STREAM ':TYI)) 
     631    ;; Discard column-position-adjust 
     632    (FUNCALL STREAM ':TYI) 
     633    ;; Discard baseline. 
     634    (FUNCALL STREAM ':TYI) 
     635    ;; Remember font line height as raster height. 
     636    (SETQ RASTER-HEIGHT (READ-KST-HALFWORD STREAM)) 
     637    ;; Keep maxing raster widths of characters into raster-width 
     638    (SETQ RASTER-WIDTH 0) 
     639    (LOOP AS HEADER = (LOGIOR (ASH (READ-KST-HALFWORD STREAM) 18.) (READ-KST-HALFWORD STREAM)) 
     640          UNTIL (= HEADER -1) 
     641          UNLESS (= HEADER 1) 
     642            DO (FERROR NIL "~O where character header expected; KST file misformatted" HEADER) 
     643      DO 
     644      ;; Ignore char's left kern. 
     645      (READ-KST-HALFWORD STREAM) 
     646      ;; Ignore its character code. 
     647      (READ-KST-HALFWORD STREAM) 
     648      ;; Max in its raster width 
     649      (SETQ CHAR-RASTER-WIDTH (READ-KST-HALFWORD STREAM)) 
     650      (SETQ RASTER-WIDTH (MAX RASTER-WIDTH CHAR-RASTER-WIDTH)) 
     651      ;; Ignore its character width. 
     652      (READ-KST-HALFWORD STREAM) 
     653      ;; Skip the bits of the character 
     654      (LET ((BYTES (* RASTER-HEIGHT (// (+ CHAR-RASTER-WIDTH 7) 8)))) 
     655        (SETQ BYTES (* 4 (// (+ BYTES 3) 4))) 
     656        (DOTIMES (I BYTES) 
     657          (FUNCALL STREAM ':TYI))))) 
     658  (VALUES RASTER-WIDTH RASTER-HEIGHT)) 
    528659 
    529660;; Fetch the next 8-bit byte where stream is a 9-bit byte stream. 
     
    534665;; The car of our value is the next byte. 
    535666;; Save the value for the byte-list arg next time. 
    536 (defun read-kst-bytes (stream byte-list byte-list-head) 
    537     (or (cdr byte-list) 
    538         ;; Exhausted the word - read another. 
    539         (let ((hwd1 (read-kst-halfword stream)) 
    540               (hwd2 (read-kst-halfword stream))) 
    541              (setq byte-list byte-list-head) 
    542              ;; Turn it into 4 8-bit bytes in byte-list. 
    543              (rplaca byte-list (ldb 1210 hwd1)) 
    544              (rplaca (cdr byte-list) (ldb 0210 hwd1)) 
    545              (rplaca (cddr byte-list) 
    546                      (+ (lsh (ldb 0002 hwd1) 6) 
    547                         (ldb 1406 hwd2))) 
    548              (rplaca (cdddr byte-list) (ldb 0410 hwd2)) 
    549              byte-list))) 
     667(DEFUN READ-KST-BYTES (STREAM BYTE-LIST BYTE-LIST-HEAD) 
     668  (OR (CDR BYTE-LIST) 
     669      ;; Exhausted the word - read another. 
     670      (LET ((HWD1 (READ-KST-HALFWORD STREAM)) 
     671            (HWD2 (READ-KST-HALFWORD STREAM))) 
     672        (SETQ BYTE-LIST BYTE-LIST-HEAD) 
     673        ;; Turn it into 4 8-bit bytes in byte-list. 
     674        (RPLACA BYTE-LIST (LDB 1210 HWD1)) 
     675        (RPLACA (CDR BYTE-LIST) (LDB 0210 HWD1)) 
     676        (RPLACA (CDDR BYTE-LIST) 
     677                (+ (LSH (LDB 0002 HWD1) 6) 
     678                   (LDB 1406 HWD2))) 
     679        (RPLACA (CDDDR BYTE-LIST) (LDB 0410 HWD2)) 
     680        BYTE-LIST))) 
    550681 
    551682;; Read two 9-bit bytes from stream, make an 18-bit halfword, 
    552683;; and sign-extend it. 
    553 (defun read-kst-halfword (stream &aux hwd) 
    554     (setq hwd (+ (* (funcall stream ':tyi) 1000) 
    555                  (funcall stream ':tyi))) 
    556     (cond ((bit-test hwd 400000) 
    557            (logior hwd -400000)) 
    558           (t hwd))) 
     684(DEFUN READ-KST-HALFWORD (STREAM &AUX HWD) 
     685  (SETQ HWD (+ (* (FUNCALL STREAM ':TYI) 1000) 
     686               (FUNCALL STREAM ':TYI))) 
     687  (COND ((BIT-TEST HWD 400000) 
     688         (LOGIOR HWD -400000)) 
     689        (T HWD))) 
    559690 
     691;;; Given FONTNAME and FILENAME from FONTNAME &OPTIONAL FILENAME, canonicalize them. 
     692(DEFUN GET-OUTPUT-FILENAME-AND-FONTNAME (FONTNAME FILENAME FILE-TYPE) 
     693  (DECLARE (RETURN-LIST FONTNAME FILENAME)) 
     694  (AND (STRINGP FONTNAME) (SETQ FONTNAME (INTERN (STRING-UPCASE FONTNAME) "FONTS"))) 
     695  (OR FILENAME (SETQ FILENAME (STRING FONTNAME))) 
     696  (SETQ FILENAME (FS:MERGE-PATHNAME-DEFAULTS FILENAME (PATHNAME-DEFAULTS) FILE-TYPE)) 
     697  (VALUES FONTNAME FILENAME)) 
     698 
     699(DEFUN GET-OUTPUT-FILENAME-FROM-FONT-DESCRIPTOR (FONT-DESCRIPTOR FILENAME FILE-TYPE) 
     700  (OR FILENAME (SETQ FILENAME (STRING (FD-NAME FONT-DESCRIPTOR)))) 
     701  (FS:MERGE-PATHNAME-DEFAULTS FILENAME (PATHNAME-DEFAULTS) FILE-TYPE)) 
     702 
    560703;; It would be good to check for chars that are all zero and 
    561704;; flush them, and also to compute the actual needed raster width and use it. 
    562 (defun write-font-into-kst (fontname &optional filename &aux stream font) 
    563   (and (stringp fontname) (setq fontname (intern fontname "FONTS"))) 
    564   (setq filename (fs:file-parse-name filename nil t ':kst)) 
    565   (setq font (symeval fontname)) 
    566   (cond ((font-indexing-table font) 
    567          (let ((fd (font-name-font-descriptor fontname))) 
    568            (write-font-descriptor-into-kst fd filename))) 
    569         (t 
    570          (and (> (font-raster-height font) 
    571                  (font-char-height font)) 
    572               (format t "Warning: font raster height exceeds line height")) 
    573          (setq stream (open filename '(:fixnum :out :byte-size 9.))) 
    574          ;; Write KSTID as 0. 
    575          (dotimes (i 4) (funcall stream ':tyo 0)) 
    576          ;; Write column position adjust as 0. 
    577          (funcall stream ':tyo 0) 
    578          ;; Write baseline and height into second header word. 
    579          (funcall stream ':tyo (font-baseline font)) 
    580          (write-kst-halfword stream (font-char-height font)) 
    581          ;; Then write out all the characters. 
    582          (let (kern-table char-width-table chars-exist-table 
    583                           word-pos bit-pos byte-count byte 
    584                           char-raster-width byte-list byte-list-head) 
    585            (setq kern-table (font-left-kern-table font) 
    586                  char-width-table (font-char-width-table font)) 
    587            (errset (setq chars-exist-table (font-chars-exist-table font)) nil) 
    588            (dotimes (char-code 200) 
    589              (and chars-exist-table 
    590                   (zerop (ar-1 chars-exist-table char-code)) 
    591                   (go skip-char)) 
    592              ;; Each char must start with a word containing a 1. 
    593              (write-kst-halfword stream 0) 
    594              (write-kst-halfword stream 1) 
    595              ;; left kern and char code fill the next word. 
    596              (write-kst-halfword stream 
    597                                  (or (and kern-table (ar-1 kern-table char-code)) 0)) 
    598              (write-kst-halfword stream char-code) 
    599              ;; Raster width and char width are the next word. 
    600              (setq char-raster-width (max 1 (font-char-min-raster-width font char-code))) 
    601              (write-kst-halfword stream char-raster-width) 
    602              (write-kst-halfword stream  
    603                                  (cond (char-width-table (or (ar-1 char-width-table char-code) 0)) 
    604                                        (t (font-char-width font)))) 
    605              ;; Write out the bits of the character 
    606              ;; Word-pos and bit-pos are used to point at a bit in the font. 
    607              (setq word-pos (* (font-words-per-char font) char-code)) 
    608              (setq bit-pos 0 byte-count 0) 
    609              ;; Byte-list and its head are used to accumulate 4 bytes 
    610              ;; and then output them at once as a word. 
    611              ;; This is needed because the stream wants 9-bit bytes. 
    612              (setq byte-list-head (list nil nil nil nil)) 
    613              (setq byte-list byte-list-head) 
    614              (dotimes (vpos (font-char-height font)) 
    615                ;; Prepare to extract next row of char from font. 
    616                (and (> (+ bit-pos (font-raster-width font)) 32.) 
    617                     (setq word-pos (1+ word-pos) bit-pos 0)) 
    618                (setq byte 0) 
    619                ;; Get the row a bit at a time and fill up 8-bit bytes. 
    620                ;; Output the bytes when full.  Output the excess at the end. 
    621                ;; Count the bytes output with byte-count 
    622                (dotimes (hpos char-raster-width) 
    623                  (cond ((and (= (\ hpos 8) 0) (not (zerop hpos))) 
    624                         (setq byte-count (1+ byte-count)) 
    625                         (setq byte-list 
    626                               (write-kst-byte stream byte byte-list byte-list-head)) 
    627                         (setq byte 0))) 
    628                  (or ( 
    629  vpos (font-raster-height font)) 
    630                      (setq byte (+ byte (lsh (ar-1 font 
    631                                                    (+ (* 32. word-pos) hpos bit-pos)) 
    632                                              (\ hpos 8)))))) 
    633                (setq byte-count (1+ byte-count)) 
    634                (setq byte-list (write-kst-byte stream byte byte-list byte-list-head)) 
    635                (setq bit-pos (+ bit-pos (font-raster-width font)))) 
    636              ;; Pad to a word boundary. 
    637              (do () ((zerop (\ byte-count 4))) 
    638                (setq byte-list (write-kst-byte stream 0 byte-list byte-list-head)) 
    639                (setq byte-count (1+ byte-count))) 
    640              skip-char) 
    641            ;; Mark end of file with two -1 words. 
    642            (dotimes (i 8) 
    643              (funcall stream ':tyo -1))) 
    644          (close stream)))) 
     705(DEFUN WRITE-FONT-INTO-KST (FONTNAME &OPTIONAL FILENAME &AUX FONT FONT-LENGTH) 
     706  (MULTIPLE-VALUE (FONTNAME FILENAME) 
     707    (GET-OUTPUT-FILENAME-AND-FONTNAME FONTNAME FILENAME "KST")) 
     708  (SETQ FONT (SYMEVAL FONTNAME)) 
     709  (SETQ FONT-LENGTH (FONT-FILL-POINTER FONT)) 
     710  (OR (AND FONT-LENGTH ( 
     711 FONT-LENGTH 200)) 
     712      (SETQ FONT-LENGTH 200)) 
     713  (COND ((FONT-INDEXING-TABLE FONT) 
     714         (LET ((FD (FONT-NAME-FONT-DESCRIPTOR FONTNAME))) 
     715           (WRITE-FONT-DESCRIPTOR-INTO-KST FD FILENAME))) 
     716        (T 
     717         (AND (> (FONT-RASTER-HEIGHT FONT) 
     718                 (FONT-CHAR-HEIGHT FONT)) 
     719              (FORMAT T "Warning: font raster height exceeds line height")) 
     720         (WITH-OPEN-FILE (STREAM FILENAME '(:FIXNUM :OUT :BYTE-SIZE 9.)) 
     721           ;; Write KSTID as 0. 
     722           (DOTIMES (I 4) (FUNCALL STREAM ':TYO 0)) 
     723           ;; Write column position adjust as 0. 
     724           (FUNCALL STREAM ':TYO 0) 
     725           ;; Write baseline and height into second header word. 
     726           (FUNCALL STREAM ':TYO (FONT-BASELINE FONT)) 
     727           (WRITE-KST-HALFWORD STREAM (FONT-CHAR-HEIGHT FONT)) 
     728           ;; Then write out all the characters. 
     729           (LET (KERN-TABLE CHAR-WIDTH-TABLE CHARS-EXIST-TABLE 
     730                 WORD-POS BIT-POS BYTE-COUNT BYTE 
     731                 CHAR-RASTER-WIDTH BYTE-LIST BYTE-LIST-HEAD) 
     732             (SETQ KERN-TABLE (FONT-LEFT-KERN-TABLE FONT) 
     733                   CHAR-WIDTH-TABLE (FONT-CHAR-WIDTH-TABLE FONT)) 
     734             (ERRSET (SETQ CHARS-EXIST-TABLE (FONT-CHARS-EXIST-TABLE FONT)) NIL) 
     735             (DOTIMES (CHAR-CODE FONT-LENGTH) 
     736               (AND CHARS-EXIST-TABLE 
     737                    (ZEROP (AREF CHARS-EXIST-TABLE CHAR-CODE)) 
     738                    (GO SKIP-CHAR)) 
     739               ;; Each char must start with a word containing a 1. 
     740               (WRITE-KST-HALFWORD STREAM 0) 
     741               (WRITE-KST-HALFWORD STREAM 1) 
     742               ;; left kern and char code fill the next word. 
     743               (WRITE-KST-HALFWORD STREAM 
     744                                   (OR (AND KERN-TABLE (AREF KERN-TABLE CHAR-CODE)) 0)) 
     745               (WRITE-KST-HALFWORD STREAM CHAR-CODE) 
     746               ;; Raster width and char width are the next word. 
     747               (SETQ CHAR-RASTER-WIDTH (MAX 1 (FONT-CHAR-MIN-RASTER-WIDTH FONT CHAR-CODE))) 
     748               (WRITE-KST-HALFWORD STREAM CHAR-RASTER-WIDTH) 
     749               (WRITE-KST-HALFWORD STREAM  
     750                                   (COND (CHAR-WIDTH-TABLE 
     751                                          (OR (AREF CHAR-WIDTH-TABLE CHAR-CODE) 0)) 
     752                                         (T (FONT-CHAR-WIDTH FONT)))) 
     753               ;; Write out the bits of the character 
     754               ;; Word-pos and bit-pos are used to point at a bit in the font. 
     755               (SETQ WORD-POS (* (FONT-WORDS-PER-CHAR FONT) CHAR-CODE)) 
     756               (SETQ BIT-POS 0 BYTE-COUNT 0) 
     757               ;; Byte-list and its head are used to accumulate 4 bytes 
     758               ;; and then output them at once as a word. 
     759               ;; This is needed because the stream wants 9-bit bytes. 
     760               (SETQ BYTE-LIST-HEAD (LIST NIL NIL NIL NIL)) 
     761               (SETQ BYTE-LIST BYTE-LIST-HEAD) 
     762               (COND ((NOT (ZEROP CHAR-RASTER-WIDTH)) 
     763                      (DOTIMES (VPOS (FONT-CHAR-HEIGHT FONT)) 
     764                        ;; Prepare to extract next row of char from font. 
     765                        (AND (> (+ BIT-POS (FONT-RASTER-WIDTH FONT)) 32.) 
     766                             (SETQ WORD-POS (1+ WORD-POS) BIT-POS 0)) 
     767                        (SETQ BYTE 0) 
     768                        ;; Get the row a bit at a time and fill up 8-bit bytes. 
     769                        ;; Output the bytes when full.  Output the excess at the end. 
     770                        ;; Count the bytes output with byte-count 
     771                        (DOTIMES (HPOS CHAR-RASTER-WIDTH) 
     772                          (COND ((AND (= (\ HPOS 8) 0) (NOT (ZEROP HPOS))) 
     773                                 (SETQ BYTE-COUNT (1+ BYTE-COUNT)) 
     774                                 (SETQ BYTE-LIST 
     775                                       (WRITE-KST-BYTE STREAM BYTE BYTE-LIST BYTE-LIST-HEAD)) 
     776                                 (SETQ BYTE 0))) 
     777                          (OR ( 
     778 VPOS (FONT-RASTER-HEIGHT FONT)) 
     779                              (SETQ BYTE (+ BYTE (LSH (AREF FONT 
     780                                                            (+ (* 32. WORD-POS) HPOS BIT-POS)) 
     781                                                      (\ HPOS 8)))))) 
     782                        (SETQ BYTE-LIST (WRITE-KST-BYTE STREAM BYTE BYTE-LIST BYTE-LIST-HEAD)) 
     783                        (SETQ BYTE-COUNT (1+ BYTE-COUNT)) 
     784                        (SETQ BIT-POS (+ BIT-POS (FONT-RASTER-WIDTH FONT)))) 
     785                      ;; Pad to a word boundary. 
     786                      (DO () ((ZEROP (\ BYTE-COUNT 4))) 
     787                        (SETQ BYTE-LIST (WRITE-KST-BYTE STREAM 0 BYTE-LIST BYTE-LIST-HEAD)) 
     788                        (SETQ BYTE-COUNT (1+ BYTE-COUNT))))) 
     789               SKIP-CHAR) 
     790             ;; Mark end of file with two -1 words. 
     791             (DOTIMES (I 8) 
     792               (FUNCALL STREAM ':TYO -1))) 
     793           (FUNCALL STREAM ':CLOSE) 
     794           (FUNCALL STREAM ':TRUENAME))))) 
    645795 
    646 (defun write-font-descriptor-into-kst (fd filename &aux stream) 
    647     (setq stream (open (fs:file-parse-name filename nil t ':kst) 
    648                        '(:fixnum :out :byte-size 9.))) 
     796(DEFUN WRITE-FONT-DESCRIPTOR-INTO-KST (FD &OPTIONAL FILENAME 
     797                                          &AUX (FONT-LENGTH (ARRAY-ACTIVE-LENGTH FD))) 
     798  (SETQ FILENAME (GET-OUTPUT-FILENAME-FROM-FONT-DESCRIPTOR FD FILENAME "KST")) 
     799  (WITH-OPEN-FILE (STREAM FILENAME '(:FIXNUM :OUT :BYTE-SIZE 9.)) 
    649800    ;; Write KSTID as 0. 
    650     (dotimes (i 4) (funcall stream ':tyo 0)) 
     801    (DOTIMES (I 4) (FUNCALL STREAM ':TYO 0)) 
    651802    ;; Write column position adjust as 0. 
    652     (funcall stream ':tyo 0) 
     803    (FUNCALL STREAM ':TYO 0) 
    653804    ;; Write baseline and height into second header word. 
    654     (funcall stream ':tyo (fd-baseline fd)) 
    655     (write-kst-halfword stream (fd-line-spacing fd)) 
     805    (FUNCALL STREAM ':TYO (FD-BASELINE FD)) 
     806    (WRITE-KST-HALFWORD STREAM (FD-LINE-SPACING FD)) 
    656807    ;; Then write out all the characters. 
    657     (let (cd char-height byte-count byte byte-list byte-list-head) 
    658        (dotimes (char-code 200) 
    659           (cond ((and (setq cd (ar-1 fd char-code)) 
     808    (LET (CD CHAR-HEIGHT BYTE-COUNT BYTE BYTE-LIST BYTE-LIST-HEAD) 
     809       (DOTIMES (CHAR-CODE FONT-LENGTH) 
     810          (COND ((AND (SETQ CD (AREF FD CHAR-CODE)) 
    660811                      ;; Wide fonts without chars-exist-tables can have 0-width chars. 
    661                       (or (not (zerop (array-dimension-n 2 cd))) 
    662                           (not (zerop (cd-char-width cd))))) 
     812                      (OR (NOT (ZEROP (ARRAY-DIMENSION-N 2 CD))) 
     813                          (NOT (ZEROP (CD-CHAR-WIDTH CD))))) 
    663814            ;; Each char must start with a word containing a 1. 
    664             (write-kst-halfword stream 0) 
    665             (write-kst-halfword stream 1) 
     815            (WRITE-KST-HALFWORD STREAM 0) 
     816            (WRITE-KST-HALFWORD STREAM 1) 
    666817            ;; left kern and char code fill the next word. 
    667             (write-kst-halfword stream (cd-char-left-kern cd)) 
    668             (write-kst-halfword stream char-code) 
     818            (WRITE-KST-HALFWORD STREAM (CD-CHAR-LEFT-KERN CD)) 
     819            (WRITE-KST-HALFWORD STREAM CHAR-CODE) 
    669820            ;; Raster width and char width are the next word. 
    670             (write-kst-halfword stream (array-dimension-n 2 cd)) 
    671             (write-kst-halfword stream (cd-char-width cd)) 
     821            (WRITE-KST-HALFWORD STREAM (ARRAY-DIMENSION-N 2 CD)) 
     822            (WRITE-KST-HALFWORD STREAM (CD-CHAR-WIDTH CD)) 
    672823            ;; Write out the bits of the character 
    673824            ;; Byte-list and its head are used to accumulate 4 bytes 
    674825            ;; and then output them at once as a word. 
    675826            ;; This is needed because the stream wants 9-bit bytes. 
    676             (setq byte-list-head (list nil nil nil nil)) 
    677             (setq byte-list byte-list-head) 
    678             (setq byte-count 0) 
    679             (setq char-height (array-dimension-n 1 cd)) 
    680             (and (> char-height (fd-line-spacing fd)) 
    681                  (ferror nil "Character ~C height exceeds font line height in KST file" 
    682                          char-code)) 
    683             (dotimes (vpos (fd-line-spacing fd)) 
    684                ;; Prepare to extract next row of char from font. 
    685                (setq byte 0) 
    686                ;; Get the row a bit at a time and fill up 8-bit bytes. 
    687                ;; Output the bytes when full.  Output the excess at the end. 
    688                ;; Count the bytes output with byte-count 
    689                (dotimes (hpos (array-dimension-n 2 cd)) 
    690                    (cond ((and (= (\ hpos 8) 0) (not (zerop hpos))) 
    691                           (setq byte-count (1+ byte-count)) 
    692                           (setq byte-list 
    693                                 (write-kst-byte stream byte byte-list byte-list-head)) 
    694                           (setq byte 0))) 
    695                    (or ( 
    696  vpos char-height) 
    697                        (setq byte (+ byte (lsh (ar-2 cd vpos hpos) (\ hpos 8)))))) 
    698                (setq byte-count (1+ byte-count)) 
    699                (setq byte-list (write-kst-byte stream byte byte-list byte-list-head))) 
    700             ;; Pad to a word boundary. 
    701             (do () ((zerop (\ byte-count 4))) 
    702                (setq byte-list (write-kst-byte stream 0 byte-list byte-list-head)) 
    703                (setq byte-count (1+ byte-count)))))) 
     827            (SETQ BYTE-LIST-HEAD (LIST NIL NIL NIL NIL)) 
     828            (SETQ BYTE-LIST BYTE-LIST-HEAD) 
     829            (SETQ BYTE-COUNT 0) 
     830            (SETQ CHAR-HEIGHT (ARRAY-DIMENSION-N 1 CD)) 
     831            (AND (> CHAR-HEIGHT (FD-LINE-SPACING FD)) 
     832                 (FERROR NIL "Character ~C height exceeds font line height in KST file" 
     833                         CHAR-CODE)) 
     834            (COND ((NOT (ZEROP (ARRAY-DIMENSION-N 2 CD))) 
     835                   (DOTIMES (VPOS (FD-LINE-SPACING FD)) 
     836                     ;; Prepare to extract next row of char from font. 
     837                     (SETQ BYTE 0) 
     838                     ;; Get the row a bit at a time and fill up 8-bit bytes. 
     839                     ;; Output the bytes when full.  Output the excess at the end. 
     840                     ;; Count the bytes output with byte-count 
     841                     (DOTIMES (HPOS (ARRAY-DIMENSION-N 2 CD)) 
     842                       (COND ((AND (= (\ HPOS 8) 0) (NOT (ZEROP HPOS))) 
     843                              (SETQ BYTE-COUNT (1+ BYTE-COUNT)) 
     844                              (SETQ BYTE-LIST 
     845                                    (WRITE-KST-BYTE STREAM BYTE BYTE-LIST BYTE-LIST-HEAD)) 
     846                              (SETQ BYTE 0))) 
     847                       (OR ( 
     848 VPOS CHAR-HEIGHT) 
     849                           (SETQ BYTE (+ BYTE (LSH (AREF CD VPOS HPOS) (\ HPOS 8)))))) 
     850                     (SETQ BYTE-LIST (WRITE-KST-BYTE STREAM BYTE BYTE-LIST BYTE-LIST-HEAD)) 
     851                     (SETQ BYTE-COUNT (1+ BYTE-COUNT))) 
     852                   ;; Pad to a word boundary. 
     853                   (DO () ((ZEROP (\ BYTE-COUNT 4))) 
     854                     (SETQ BYTE-LIST (WRITE-KST-BYTE STREAM 0 BYTE-LIST BYTE-LIST-HEAD)) 
     855                     (SETQ BYTE-COUNT (1+ BYTE-COUNT)))))))) 
    704856       ;; Mark end of file with two -1 words. 
    705        (dotimes (i 8) 
    706             (funcall stream ':tyo -1))) 
    707     (close stream)) 
     857       (DOTIMES (I 8) 
     858            (FUNCALL STREAM ':TYO -1))) 
     859    (FUNCALL STREAM ':CLOSE) 
     860    (FUNCALL STREAM ':TRUENAME))) 
    708861 
    709862;; Write an 8-bit byte to the kst file.  We pack 4 bytes per word. 
     
    711864;; Byte-list-head should be a list of length 4 we can clobber. 
    712865;; byte-list should initially be the same thing;  we return a new value to set it to. 
    713 (defun write-kst-byte (stream byte byte-list byte-list-head) 
    714     (rplaca byte-list byte) 
    715     (pop byte-list) 
    716     (cond ((null byte-list) 
    717            (setq byte-list byte-list-head) 
    718            (write-kst-halfword stream 
    719                   (+ (lsh (first byte-list) 10.) 
    720                      (lsh (second byte-list) 2.) 
    721                      (ldb 0602 (third byte-list)))) 
    722            (write-kst-halfword stream 
    723                   (+ (lsh (ldb 0006 (third byte-list)) 12.) 
    724                      (lsh (fourth byte-list) 4))))) 
    725     byte-list) 
    726  
    727 (defun write-kst-halfword (stream halfword) 
    728     (funcall stream ':tyo (ldb 1111 halfword)) 
    729     (funcall stream ':tyo (ldb 0011 halfword))) 
     866(DEFUN WRITE-KST-BYTE (STREAM BYTE BYTE-LIST BYTE-LIST-HEAD) 
     867  (RPLACA BYTE-LIST BYTE) 
     868  (POP BYTE-LIST) 
     869  (COND ((NULL BYTE-LIST) 
     870         (SETQ BYTE-LIST BYTE-LIST-HEAD) 
     871         (WRITE-KST-HALFWORD STREAM 
     872                             (+ (LSH (FIRST BYTE-LIST) 10.) 
     873                                (LSH (SECOND BYTE-LIST) 2.) 
     874                                (LDB 0602 (THIRD BYTE-LIST)))) 
     875         (WRITE-KST-HALFWORD STREAM 
     876                             (+ (LSH (LDB 0006 (THIRD BYTE-LIST)) 12.) 
     877                                (LSH (FOURTH BYTE-LIST) 4))))) 
     878  BYTE-LIST) 
     879 
     880(DEFUN WRITE-KST-HALFWORD (STREAM HALFWORD) 
     881  (FUNCALL STREAM ':TYO (LDB 1111 HALFWORD)) 
     882  (FUNCALL STREAM ':TYO (LDB 0011 HALFWORD))) 
    730883 
    731884;; Compute the smallest raster width needed to store the specified char 
    732885;; as defined by the specified font. 
    733886;; low-level means we are looking at one sub-character in a wide font. 
    734 (defun font-char-min-raster-width (font char-code &optional low-level 
    735                                         &aux bit-pos word-pos tem 
    736                                         min-raster-width f-raster-width raster-height) 
    737     (cond ((and (not low-level) 
    738                 (setq tem (font-indexing-table font))) 
     887(DEFUN FONT-CHAR-MIN-RASTER-WIDTH (FONT CHAR-CODE 
     888                                   &OPTIONAL LOW-LEVEL 
     889                                   &AUX BIT-POS WORD-POS TEM 
     890                                        MIN-RASTER-WIDTH F-RASTER-WIDTH RASTER-HEIGHT) 
     891    (COND ((AND (NOT LOW-LEVEL) 
     892                (SETQ TEM (FONT-INDEXING-TABLE FONT))) 
    739893           ;; If it's a wide font, go by the number of vertical stripes, 
    740894           ;; but also see how wide the rightmost stripe really needs to be. 
    741            (max 0 
    742                 (+ (* 32. (- (ar-1 tem (1+ char-code)) (ar-1 tem char-code))) 
    743                    -32. 
    744                    (font-char-min-raster-width font (1- (ar-1 tem (1+ char-code))) t)))) 
    745           (t (setq word-pos (* char-code (font-words-per-char font)) 
    746                    bit-pos 0 
    747                    min-raster-width 0 
    748                    f-raster-width (font-raster-width font) 
    749                    raster-height (font-raster-height font)) 
    750              (dotimes (vpos raster-height) 
    751                  (and (> (+ bit-pos f-raster-width) 32.) 
    752                       (setq bit-pos 0 word-pos (1+ word-pos))) 
    753                  (do ((hpos 0 (1+ hpos)) (index (+ bit-pos (lsh word-pos 5)) (1+ index))) 
    754                      ((= hpos f-raster-width)) 
    755                     (or (zerop (ar-1 font index)) 
    756                         (setq min-raster-width (max (1+ hpos) min-raster-width)))) 
    757                  (setq bit-pos (+ f-raster-width bit-pos))) 
    758              min-raster-width))) 
     895           (LET ((START-IDX (AREF TEM CHAR-CODE)) 
     896                 (END-IDX (AREF TEM (1+ CHAR-CODE)))) 
     897             (IF (= START-IDX END-IDX) 
     898                 0 
     899                 (MAX 0 
     900                      (+ (* 32. (- END-IDX START-IDX)) 
     901                         -32. 
     902                         (FONT-CHAR-MIN-RASTER-WIDTH FONT (1- END-IDX) T)))))) 
     903          (T (SETQ WORD-POS (* CHAR-CODE (FONT-WORDS-PER-CHAR FONT)) 
     904                   BIT-POS 0 
     905                   MIN-RASTER-WIDTH 0 
     906                   F-RASTER-WIDTH (FONT-RASTER-WIDTH FONT) 
     907                   RASTER-HEIGHT (FONT-RASTER-HEIGHT FONT)) 
     908             (DOTIMES (VPOS RASTER-HEIGHT) 
     909                 (AND (> (+ BIT-POS F-RASTER-WIDTH) 32.) 
     910                      (SETQ BIT-POS 0 WORD-POS (1+ WORD-POS))) 
     911                 (DO ((HPOS 0 (1+ HPOS)) (INDEX (+ BIT-POS (LSH WORD-POS 5)) (1+ INDEX))) 
     912                     ((= HPOS F-RASTER-WIDTH)) 
     913                    (OR (ZEROP (AREF FONT INDEX)) 
     914                        (SETQ MIN-RASTER-WIDTH (MAX (1+ HPOS) MIN-RASTER-WIDTH)))) 
     915                 (SETQ BIT-POS (+ F-RASTER-WIDTH BIT-POS))) 
     916             MIN-RASTER-WIDTH))) 
    759917 
    760918;; ALTO .AL format 
     919;;;??? Not yet converted to load more than 200 chars into a font. 
     920 
    761921;; Load an ALTO font file into a font, the easy way, via a font descriptor 
    762922(DEFUN READ-AL-INTO-FONT (FILENAME &OPTIONAL FONTNAME) 
    763   (SETQ FILENAME (FS:FILE-PARSE-NAME FILENAME NIL T ':AL)) 
    764   (OR FONTNAME (SETQ FONTNAME (FUNCALL FILENAME ':NAME))) 
    765   (AND (STRINGP FONTNAME) (SETQ FONTNAME (INTERN FONTNAME "FONTS"))) 
     923  (MULTIPLE-VALUE (FILENAME FONTNAME) 
     924    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AL")) 
    766925  (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME 
    767926                                     (READ-AL-INTO-FONT-DESCRIPTOR FILENAME FONTNAME)) 
    768   (SYMEVAL FONTNAME)) 
     927  FONTNAME) 
    769928 
    770929;; Load an ALTO font file into a font descriptor 
    771930(DEFUN READ-AL-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME 
    772                                               &AUX FD STREAM ARRAY LINE-HEIGHT) 
    773   (SETQ FILENAME (FS:FILE-PARSE-NAME FILENAME NIL T ':AL)) 
    774   (OR FONTNAME (SETQ FONTNAME (FUNCALL FILENAME ':NAME))) 
    775   (AND (STRINGP FONTNAME) (SETQ FONTNAME (INTERN FONTNAME "FONTS"))) 
     931                                     &AUX FD ARRAY LINE-HEIGHT PROPORTIONAL MAX-WIDTH) 
     932  (MULTIPLE-VALUE (FILENAME FONTNAME) 
     933    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AL")) 
    776934  (SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME)) 
    777935  (SETF (FD-NAME FD) FONTNAME) 
    778   (SETQ STREAM (OPEN FILENAME '(:IN :FIXNUM))) 
    779   (UNWIND-PROTECT 
    780    (PROGN 
     936  (WITH-OPEN-FILE (STREAM FILENAME '(:IN :FIXNUM)) 
    781937    (SETQ LINE-HEIGHT (FUNCALL STREAM ':TYI)) 
    782938    (SETF (FD-LINE-SPACING FD) LINE-HEIGHT) 
    783939    (SETF (FD-BLINKER-HEIGHT FD) LINE-HEIGHT) 
    784940    (LET ((BASELINE-AND-MAX-WIDTH (FUNCALL STREAM ':TYI))) 
     941      (SETQ PROPORTIONAL (LDB-TEST 1701 BASELINE-AND-MAX-WIDTH)) 
    785942      (SETF (FD-BASELINE FD) (LDB 1007 BASELINE-AND-MAX-WIDTH)) 
    786       (SETF (FD-SPACE-WIDTH FD) (LDB 0010 BASELINE-AND-MAX-WIDTH))) 
    787     (SETQ ARRAY (MAKE-ARRAY NIL 'ART-16B 1000. NIL '(0))) 
     943      (SETF (FD-SPACE-WIDTH FD) (SETQ MAX-WIDTH (LDB 0010 BASELINE-AND-MAX-WIDTH)))) 
     944    (SETQ ARRAY (MAKE-ARRAY 1000. ':TYPE 'ART-16B ':LEADER-LIST '(0))) 
    788945    (DO CH (FUNCALL STREAM ':TYI) (FUNCALL STREAM ':TYI) (NULL CH) 
    789946      (ARRAY-PUSH-EXTEND ARRAY CH))) 
    790    (FUNCALL STREAM ':CLOSE)) 
    791947  (DO ((CH 0 (1+ CH)) 
    792948       (CD) 
    793949       (CHAR-WIDTH)) 
    794950      (( 
    795  CH 200)) 
     951 CH 200))       ;Alto font could have 400 characters, our fonts don't yet 
    796952    (SETQ CHAR-WIDTH 0) 
    797953    (DO ((IDX CH) 
     
    803959          (SETQ CHAR-WIDTH (+ CHAR-WIDTH 16.) 
    804960                IDX XW) 
    805           (SETQ CHAR-WIDTH (+ CHAR-WIDTH XW)) 
    806           (RETURN))) 
    807     (SETQ CD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (NIL ART-1B (LIST LINE-HEIGHT CHAR-WIDTH)))) 
     961          (RETURN (SETQ CHAR-WIDTH (+ CHAR-WIDTH XW))))) 
     962    (SETQ CD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (:TYPE ART-1B 
     963                                               :LENGTH (LIST LINE-HEIGHT CHAR-WIDTH)))) 
    808964    (SETF (CD-CHAR-WIDTH CD) CHAR-WIDTH) 
    809965    (AND (= CH #\SP) (SETF (FD-SPACE-WIDTH FD) CHAR-WIDTH)) 
     
    825981      ((= I IDX)) 
    826982    (DO ((BITS (AREF ARRAY I) (LSH BITS 1)) 
    827          (X XOFF (1+ X))) 
    828         ((ZEROP BITS)) 
     983         (X XOFF (1+ X)) 
     984         (CW (CD-CHAR-WIDTH CD))) 
     985        ((OR (ZEROP BITS) ( 
     986 X CW)))                ;Can be garbage to right of raster 
    829987      (AND (BIT-TEST 100000 BITS) 
    830988           (ASET 1 CD Y X)))) 
    831989  (OR (BIT-TEST 1 XW) 
    832990      (READ-AL-INTO-FONT-DESCRIPTOR-1 CD ARRAY (// XW 2) (+ XOFF 16.)))) 
     991 
     992(DEFUN WRITE-FONT-INTO-AL (FONTNAME &OPTIONAL FILENAME) 
     993  (MULTIPLE-VALUE (FONTNAME FILENAME) 
     994    (GET-OUTPUT-FILENAME-AND-FONTNAME FONTNAME FILENAME "AL")) 
     995  (LET ((FD (FONT-NAME-FONT-DESCRIPTOR FONTNAME))) 
     996    (WRITE-FONT-DESCRIPTOR-INTO-AL FD FILENAME))) 
     997 
     998;I don't think this does the desired thing for variable-width ("proportional") fonts 
     999(DEFUN WRITE-FONT-DESCRIPTOR-INTO-AL (FD &OPTIONAL FILENAME &AUX ARRAY CARRAY LINE-HEIGHT) 
     1000  (SETQ FILENAME (GET-OUTPUT-FILENAME-FROM-FONT-DESCRIPTOR FD FILENAME "AL")) 
     1001  (WITH-OPEN-FILE (STREAM FILENAME '(:OUT :FIXNUM)) 
     1002    (FUNCALL STREAM ':TYO (SETQ LINE-HEIGHT (FD-LINE-SPACING FD))) 
     1003    (FUNCALL STREAM ':TYO (DPB (FD-BASELINE FD) 1007 (FD-SPACE-WIDTH FD))) 
     1004    (SETQ ARRAY (MAKE-ARRAY 1000. ':TYPE 'ART-16B ':LEADER-LIST '(0))   ;Data array 
     1005          CARRAY (MAKE-ARRAY 400 ':TYPE 'ART-16B ':LEADER-LIST '(400))) ;Non self-rel chars 
     1006    ;; Store dummy 
     1007    (ARRAY-PUSH-EXTEND ARRAY 1) 
     1008    (ARRAY-PUSH-EXTEND ARRAY 0) 
     1009    (LOOP FOR CH FROM 0 BELOW 200 
     1010          AS CD = (AREF FD CH) 
     1011          AS CHAR-WIDTH = (CD-CHAR-WIDTH CD) 
     1012          DO (LOOP WITH CH = CH WITH (XW HD-XH) 
     1013                   FOR XOFF FROM 0 BY 16. BELOW CHAR-WIDTH 
     1014                   DO (SETQ HD-XH (WRITE-AL-COLUMN CD XOFF ARRAY)) 
     1015                      (ASET (ARRAY-LEADER ARRAY 0) CARRAY CH) 
     1016                      (SETQ XW (IF (> (- CHAR-WIDTH XOFF) 16.) 
     1017                                   (* (SETQ CH (PROG1 (ARRAY-LEADER CARRAY 0) 
     1018                                                      (ARRAY-PUSH-EXTEND CARRAY 0))) 
     1019                                      2) 
     1020                                   (1+ (* (- CHAR-WIDTH XOFF) 2)))) 
     1021                      (ARRAY-PUSH-EXTEND ARRAY XW) 
     1022                      (ARRAY-PUSH-EXTEND ARRAY HD-XH))) 
     1023    (LOOP FOR I FROM 0 BELOW (ARRAY-ACTIVE-LENGTH CARRAY)       ;Make self-relative 
     1024          DO (ASET (- (+ (AREF CARRAY I) (ARRAY-ACTIVE-LENGTH CARRAY)) I) 
     1025                   CARRAY I)) 
     1026    (FUNCALL STREAM ':STRING-OUT CARRAY) 
     1027    (FUNCALL STREAM ':STRING-OUT ARRAY) 
     1028    (FUNCALL STREAM ':CLOSE) 
     1029    (FUNCALL STREAM ':TRUENAME))) 
     1030 
     1031(DEFUN WRITE-AL-COLUMN-ROW (CD XOFF Y) 
     1032  (LOOP WITH STUFF = 0 
     1033        FOR X FROM (+ XOFF (CD-CHAR-LEFT-KERN CD)) BELOW (ARRAY-DIMENSION-N 2 CD) 
     1034        AS MASK = 100000 THEN (LSH MASK -1) UNTIL (ZEROP MASK) 
     1035        WHEN (AND (NOT (MINUSP X)) (NOT (ZEROP (AREF CD Y X)))) 
     1036          DO (SETQ STUFF (LOGIOR STUFF MASK)) 
     1037        FINALLY (RETURN STUFF))) 
     1038 
     1039(DEFUN WRITE-AL-COLUMN (CD XOFF ARRAY &AUX (HD 0) (XC 0)) 
     1040  (LOOP FOR Y FROM 0 TO (LOOP FOR Y FROM (1- (ARRAY-DIMENSION-N 1 CD)) DOWNTO 0 
     1041                              WHILE (ZEROP (WRITE-AL-COLUMN-ROW CD XOFF Y)) 
     1042                              FINALLY (RETURN Y)) 
     1043        AS ROW = (WRITE-AL-COLUMN-ROW CD XOFF Y) 
     1044        DO (IF (AND (ZEROP ROW) (ZEROP XC)) 
     1045               (SETQ HD (1+ HD)) 
     1046               (ARRAY-PUSH-EXTEND ARRAY ROW) 
     1047               (SETQ XC (1+ XC)))) 
     1048  (DPB HD 1010 XC)) 
    8331049 
     1050;; ALTO .KS format 
     1051;; Load a kerned-strike file into a font 
     1052(DEFUN READ-KS-INTO-FONT (FILENAME &OPTIONAL FONTNAME) 
     1053  (MULTIPLE-VALUE (FILENAME FONTNAME) 
     1054    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "KS")) 
     1055  (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME 
     1056        (READ-KS-INTO-FONT-DESCRIPTOR FILENAME FONTNAME)) 
     1057  FONTNAME) 
     1058 
     1059;; Load a kerned-strike font file into a font descriptor 
     1060(DEFUN READ-KS-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME 
     1061                                              &AUX FD LINE-HEIGHT MAX-WIDTH WD FIXED-WIDTH 
     1062                                              MIN-CHAR MAX-CHAR STRIKE-NWDS FBBOX 
     1063                                              ASCENT DESCENT WORDS-PER-RASTER 
     1064                                              BITMAP BITMAP16 INDEX) 
     1065  (MULTIPLE-VALUE (FILENAME FONTNAME) 
     1066    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "KS")) 
     1067  (SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME)) 
     1068  (SETF (FD-NAME FD) FONTNAME) 
     1069  (WITH-OPEN-FILE (STREAM FILENAME '(:IN :FIXNUM)) 
     1070    (SETQ WD (FUNCALL STREAM ':TYI)) 
     1071    (OR (BIT-TEST 100000 WD) (FERROR NIL "Not /"new format/"")) 
     1072    (AND (BIT-TEST 40000 WD) (FERROR NIL "StrikeIndex format not understood")) 
     1073    (SETQ FIXED-WIDTH (BIT-TEST 20000 WD)) 
     1074    (OR (BIT-TEST 10000 WD) (FERROR NIL "PlainStrike format not understood")) 
     1075    (SETQ MIN-CHAR (FUNCALL STREAM ':TYI) MAX-CHAR (FUNCALL STREAM ':TYI)) 
     1076    (SETQ MAX-WIDTH (FUNCALL STREAM ':TYI)) 
     1077    (SETQ FBBOX (FUNCALL STREAM ':TYI))         ;Font bounding-box X-offset 
     1078    (IF (BIT-TEST 100000 FBBOX) (SETQ FBBOX (- FBBOX 200000)))  ;signed 
     1079    (DOTIMES (I 3) (FUNCALL STREAM ':TYI))      ;Ignore rest of font bounding box 
     1080    (SETQ STRIKE-NWDS (FUNCALL STREAM ':TYI) 
     1081          ASCENT (FUNCALL STREAM ':TYI) 
     1082          DESCENT (FUNCALL STREAM ':TYI)) 
     1083    (SETQ LINE-HEIGHT (+ ASCENT DESCENT)) 
     1084    (FUNCALL STREAM ':TYI)                      ;Ignore xoffset 
     1085    (SETQ WORDS-PER-RASTER (FUNCALL STREAM ':TYI)) 
     1086    (SETF (FD-LINE-SPACING FD) LINE-HEIGHT) 
     1087    (SETF (FD-BLINKER-HEIGHT FD) LINE-HEIGHT) 
     1088    (SETF (FD-BASELINE FD) ASCENT) 
     1089    (SETF (FD-SPACE-WIDTH FD) MAX-WIDTH) 
     1090    ;; Now copy the bitmap (the goddamn words are bit-reversed!) 
     1091    (SETQ BITMAP16 (MAKE-ARRAY (LIST WORDS-PER-RASTER LINE-HEIGHT) ':TYPE 'ART-16B) 
     1092          BITMAP (MAKE-ARRAY (LIST (* WORDS-PER-RASTER 16.) LINE-HEIGHT) 
     1093                             ':TYPE 'ART-1B ':DISPLACED-TO BITMAP16)) 
     1094    (DOTIMES (Y LINE-HEIGHT) 
     1095      (DOTIMES (X WORDS-PER-RASTER) 
     1096        (ASET (FUNCALL STREAM ':TYI) BITMAP16 (- WORDS-PER-RASTER X 1) Y))) 
     1097    ;; Copy the index segment 
     1098    (SETQ INDEX (MAKE-ARRAY (+ (- MAX-CHAR MIN-CHAR) 3) ':TYPE 'ART-16B)) 
     1099    (DOTIMES (I (ARRAY-LENGTH INDEX)) 
     1100      (ASET (FUNCALL STREAM ':TYI) INDEX I)) 
     1101    ;; Read the width table and make the characters 
     1102    (LOOP FOR CH FROM MIN-CHAR TO (MIN (1+ MAX-CHAR) 177) WITH CD 
     1103          AS XLEFT = (AREF INDEX (- CH MIN-CHAR)) 
     1104          AS XRIGHT = (AREF INDEX (1+ (- CH MIN-CHAR))) 
     1105          AS WDE = (FUNCALL STREAM ':TYI) 
     1106          UNLESS (= WDE 177777)         ;Nonexistent character 
     1107          DO (SETQ CD (MAKE-CHAR-DESCRIPTOR 
     1108                        MAKE-ARRAY (:TYPE ART-1B 
     1109                                    :LENGTH (LIST LINE-HEIGHT (- XRIGHT XLEFT))))) 
     1110             (SETF (CD-CHAR-WIDTH CD) (LDB 0010 WDE)) 
     1111             (AND (= CH #\SP) (SETF (FD-SPACE-WIDTH FD) (CD-CHAR-WIDTH CD))) 
     1112             (SETF (CD-CHAR-LEFT-KERN CD) (- (+ (LDB 1010 WDE) FBBOX))) 
     1113             (ASET CD FD CH) 
     1114             (LOOP FOR Y FROM 0 BELOW LINE-HEIGHT DO 
     1115               (LOOP FOR X FROM 0 BELOW (- XRIGHT XLEFT) 
     1116                     AS BMX DOWNFROM (- (ARRAY-DIMENSION-N 1 BITMAP) XLEFT 1) 
     1117                     DO (ASET (AREF BITMAP BMX Y) CD Y X)))) 
     1118  (SETF (FD-FILL-POINTER FD) 200) 
     1119  ;; Set width of blinker and space fields from the space character. 
     1120  (SETF (FD-BLINKER-WIDTH FD) (FD-SPACE-WIDTH FD)) 
     1121  FD)) 
     1122 
     1123;;; Some useful font munging functions 
    8341124(DEFUN THICKEN-FONT-DESCRIPTOR (FD &OPTIONAL NEW-NAME &AUX LEN NFD) 
    8351125  (OR NEW-NAME (SETQ NEW-NAME (INTERN (STRING-APPEND (FD-NAME FD) #/B) "FONTS"))) 
    836   (SETQ LEN (ARRAY-LENGTH FD) 
    837         NFD (MAKE-FONT-DESCRIPTOR MAKE-ARRAY (NIL ART-Q LEN) 
     1126  (SETQ LEN (ARRAY-ACTIVE-LENGTH FD) 
     1127        NFD (MAKE-FONT-DESCRIPTOR MAKE-ARRAY (:TYPE 'ART-Q :LENGTH LEN) 
     1128                                  FD-FILL-POINTER (FD-FILL-POINTER FD) 
    8381129                                  FD-NAME NEW-NAME 
    8391130                                  FD-LINE-SPACING (FD-LINE-SPACING FD) 
     
    8491140         (LET ((WIDTH (ARRAY-DIMENSION-N 2 CD)) 
    8501141               (HEIGHT (ARRAY-DIMENSION-N 1 CD))) 
    851            (SETQ NCD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (NIL ART-4B (LIST HEIGHT (1+ WIDTH))) 
     1142           (SETQ NCD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (:TYPE 'ART-4B 
     1143                                                       :LENGTH (LIST HEIGHT (1+ WIDTH))) 
    8521144                                           CD-CHAR-WIDTH (1+ (CD-CHAR-WIDTH CD)) 
    8531145                                           CD-CHAR-LEFT-KERN (CD-CHAR-LEFT-KERN CD))) 
     
    8591151  NFD) 
    8601152 
    861 (DEFUN THICKEN-FONT (FONT-SYMBOL &AUX FD NFD NFS NFNT) 
    862   (SETQ FD (FONT-NAME-FONT-DESCRIPTOR FONT-SYMBOL)) 
    863   (SETQ NFD (THICKEN-FONT-DESCRIPTOR FD)) 
    864   (SETQ NFS (FD-NAME NFD)) 
    865   (SETQ NFNT (FONT-DESCRIPTOR-INTO-FONT NFD)) 
    866   (SET NFS NFNT) 
    867   (PUTPROP NFS NFD 'FONT-DESCRIPTOR) 
    868   (PUTPROP NFS NFNT 'FONT-DESCRIBED) 
     1153(DEFUN THICKEN-FONT (FONT-SYMBOL &AUX FD NFD NFS) 
     1154  (SETQ FD (FONT-NAME-FONT-DESCRIPTOR FONT-SYMBOL) 
     1155        NFD (THICKEN-FONT-DESCRIPTOR FD) 
     1156        NFS (FD-NAME NFD)) 
     1157  (FONT-NAME-SET-FONT-AND-DESCRIPTOR NFS NFD) 
    8691158  NFS) 
     1159 
     1160(DEFUN UNTHICKEN-FONT-DESCRIPTOR (FD NEW-NAME &AUX LEN NFD) 
     1161  (SETQ LEN (ARRAY-ACTIVE-LENGTH FD) 
     1162        NFD (MAKE-FONT-DESCRIPTOR MAKE-ARRAY (:TYPE 'ART-Q :LENGTH LEN) 
     1163                                  FD-FILL-POINTER (FD-FILL-POINTER FD) 
     1164                                  FD-NAME NEW-NAME 
     1165                                  FD-LINE-SPACING (FD-LINE-SPACING FD) 
     1166                                  FD-BASELINE (FD-BASELINE FD) 
     1167                                  FD-BLINKER-HEIGHT (FD-BLINKER-HEIGHT FD) 
     1168                                  FD-BLINKER-WIDTH (FD-BLINKER-WIDTH FD) 
     1169                                  FD-SPACE-WIDTH (FD-SPACE-WIDTH FD))) 
     1170  (DO ((I 0 (1+ I)) 
     1171       (CD) (NCD)) 
     1172      (( 
     1173 I LEN)) 
     1174    (AND (SETQ CD (AREF FD I)) 
     1175         (LET ((WIDTH (ARRAY-DIMENSION-N 2 CD)) 
     1176               (HEIGHT (ARRAY-DIMENSION-N 1 CD))) 
     1177           (SETQ NCD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (:TYPE 'ART-4B 
     1178                                                       :LENGTH (LIST HEIGHT WIDTH)) 
     1179                                           CD-CHAR-WIDTH (CD-CHAR-WIDTH CD) 
     1180                                           CD-CHAR-LEFT-KERN (CD-CHAR-LEFT-KERN CD))) 
     1181           (COPY-ARRAY-CONTENTS CD NCD) 
     1182           ;110 100 
     1183           (DOTIMES (J HEIGHT) 
     1184             (LOOP FOR I FROM (1- WIDTH) ABOVE 0 
     1185                   AS RIGHT = 0 THEN THIS 
     1186                   AS THIS FIRST (AREF CD J I) THEN LEFT 
     1187                   AS LEFT = (AREF CD J (1- I)) 
     1188                   WHEN (AND (= LEFT 1) (= THIS 1) (= RIGHT 0)) 
     1189                     DO (ASET 0 NCD J I))) 
     1190           (ASET NCD NFD I)))) 
     1191  NFD) 
     1192 
     1193(DEFUN UNTHICKEN-FONT (FONT-SYMBOL NFS &AUX FD NFD) 
     1194  (SETQ FD (FONT-NAME-FONT-DESCRIPTOR FONT-SYMBOL) 
     1195        NFD (UNTHICKEN-FONT-DESCRIPTOR FD NFS)) 
     1196  (FONT-NAME-SET-FONT-AND-DESCRIPTOR NFS NFD) 
     1197  NFS) 
     1198 
     1199(DEFUN ROTATE-FONT-DESCRIPTOR (FD &AUX LENGTH NFD) 
     1200  (SETQ LENGTH (ARRAY-ACTIVE-LENGTH FD) 
     1201        NFD (MAKE-FONT-DESCRIPTOR :MAKE-ARRAY (:LENGTH LENGTH) 
     1202                                  FD-FILL-POINTER (FD-FILL-POINTER FD) 
     1203                                  FD-NAME (INTERN (STRING-APPEND (FD-NAME FD) #/R) "FONTS") 
     1204                                  FD-BASELINE (FD-SPACE-WIDTH FD) 
     1205                                  FD-LINE-SPACING (FD-SPACE-WIDTH FD) 
     1206                                  FD-BLINKER-HEIGHT (FD-BLINKER-WIDTH FD) 
     1207                                  FD-BLINKER-WIDTH (FD-BLINKER-HEIGHT FD) 
     1208                                  FD-SPACE-WIDTH (FD-LINE-SPACING FD) 
     1209                                  FD-ROTATION 90.)) 
     1210  (LOOP FOR CH FROM 0 BELOW LENGTH 
     1211        AS CD = (AREF FD CH) 
     1212        WHEN CD 
     1213        DO (ASET (ROTATE-CHAR-DESCRIPTOR CD) NFD CH)) 
     1214  NFD) 
     1215 
     1216(DEFUN ROTATE-CHAR-DESCRIPTOR (CD) 
     1217  (LET* ((HEI (ARRAY-DIMENSION-N 1 CD)) 
     1218         (WID (ARRAY-DIMENSION-N 2 CD)) 
     1219         (NCD (MAKE-CHAR-DESCRIPTOR :MAKE-ARRAY (:LENGTH (LIST WID HEI) 
     1220                                                         :TYPE (ARRAY-TYPE CD)) 
     1221                                    CD-CHAR-LEFT-KERN 0 
     1222                                    CD-CHAR-WIDTH HEI))) 
     1223    (LOOP FOR X FROM 0 BELOW WID 
     1224          DO (LOOP FOR Y FROM 0 BELOW HEI 
     1225                   DO (ASET (AREF CD Y X) NCD (- WID X 1) Y))) 
     1226    NCD)) 
     1227 
     1228(DEFUN ROTATE-FONT (FONT-SYMBOL &AUX FD NFD NFS) 
     1229  (SETQ FD (FONT-NAME-FONT-DESCRIPTOR FONT-SYMBOL) 
     1230        NFD (ROTATE-FONT-DESCRIPTOR FD) 
     1231        NFS (FD-NAME NFD)) 
     1232  (FONT-NAME-SET-FONT-AND-DESCRIPTOR NFS NFD) 
     1233  NFS) 
     1234 
     1235(DEFMACRO SIGN-EXTEND (16BIT-WORD) 
     1236  `(LET ((WORD ,16BIT-WORD)) 
     1237     (IF ( 
     1238 WORD 100000) 
     1239         (- WORD 200000) 
     1240         WORD))) 
     1241 
     1242(DEFMACRO HIGH-BYTE (WORD) 
     1243  `(LSH ,WORD -8)) 
     1244 
     1245(DEFMACRO LOW-BYTE (WORD) 
     1246  `(BOOLE 1 377 ,WORD)) 
     1247 
     1248;Get next 16-bit word from input-file 
     1249(DEFUN NEXT-WORD () 
     1250  (DECLARE (SPECIAL INPUT-FILE)) 
     1251  (FUNCALL INPUT-FILE ':TYI "Unexpected EOF on AC file")) 
     1252 
     1253;Read in an AC file as a Lisp machine font. 
     1254(DEFUN READ-AC-INTO-FONT (FILENAME &OPTIONAL FONTNAME) 
     1255  (MULTIPLE-VALUE (FILENAME FONTNAME) 
     1256    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AC")) 
     1257  (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME 
     1258                                     (READ-AC-INTO-FONT-DESCRIPTOR FILENAME FONTNAME)) 
     1259  FONTNAME) 
     1260 
     1261(DEFUN READ-AC-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME 
     1262                                              &AUX FAMILY-NAME FACE-CODE POINT-SIZE) 
     1263  (DECLARE (SPECIAL INPUT-FILE)) 
     1264  (MULTIPLE-VALUE (FILENAME FONTNAME) 
     1265    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AC")) 
     1266  (WITH-OPEN-FILE (INPUT-FILE FILENAME '(:READ :FIXNUM)) 
     1267    (SETF (VALUES FAMILY-NAME FACE-CODE POINT-SIZE) 
     1268          (PRESS:DECODE-FONT-NAME (STRING FONTNAME))) 
     1269    (LET ((CODE-ALIST NIL) 
     1270          (SEGMENT-DATA NIL) 
     1271          FAMILY-CODE TEM SEGMENT 
     1272          FD 
     1273          (WD 0)) 
     1274      (SETQ WD (NEXT-WORD)) 
     1275      ;; Read IXN entries (type 1) 
     1276      (DO () ((NOT (= (LSH WD -12.) 1))) 
     1277        (LET ((CODE (NEXT-WORD)) 
     1278              (NAME (PRESS:BCPL-STRING 20. INPUT-FILE))) 
     1279          (PUSH (CONS CODE NAME) CODE-ALIST)) 
     1280        (SETQ WD (NEXT-WORD))) 
     1281      ;; Find out the code number for the font family to be used, 
     1282      ;; either the specified one or the only one. 
     1283      (COND (FAMILY-NAME 
     1284             (OR (SETQ FAMILY-CODE (CAR (RASSOC FAMILY-NAME CODE-ALIST))) 
     1285                 (FERROR NIL "Font family ~A not present in AC file" FAMILY-NAME))) 
     1286            ((CDR CODE-ALIST) 
     1287             (FERROR NIL "Font dictionary ~A: font family not specified" FILENAME)) 
     1288            (T (SETQ FAMILY-CODE (CAAR CODE-ALIST)))) 
     1289      ;; Read Index Entries (type 3) for AC segments. 
     1290      (DO () ((NOT (= (LSH WD -12.) 3))) 
     1291        (SETQ WD (NEXT-WORD))                   ;family,,face 
     1292        (SETQ TEM 
     1293              (LIST (HIGH-BYTE WD)              ;Family code number. 
     1294                    (PRESS:DECODE-FACE (LOW-BYTE WD))   ;Face name 
     1295                    (PROGN (SETQ WD (NEXT-WORD))        ;bc,,ec 
     1296                           (HIGH-BYTE WD))      ;First code 
     1297                    (LOW-BYTE WD)               ;Last code 
     1298                    (NEXT-WORD)                 ;Size 
     1299                    (NEXT-WORD)                 ;Rotation 
     1300                    (+ (LSH (NEXT-WORD) 16.) (NEXT-WORD))       ;Segment SA 
     1301                    (+ (LSH (NEXT-WORD) 16.) (NEXT-WORD))       ;Segment Len 
     1302                    (NEXT-WORD)                 ;horiz resolution 
     1303                    (NEXT-WORD)))               ;vert resolution 
     1304        (AND (= (CAR TEM) FAMILY-CODE) (PUSH TEM SEGMENT-DATA)) 
     1305        (SETQ WD (NEXT-WORD))) 
     1306      ;; Now should have type-0 entry (end of index) 
     1307      (SELECTQ (LSH WD -12.) 
     1308        (0 ) 
     1309        (5 (FERROR NIL "There are OrbitChars segments in this file -- I don't grok them")) 
     1310        (OTHERWISE 
     1311          (FERROR NIL "~O - Bullshit in file where type 0 IX expected" WD))) 
     1312      ;; Now either there should be only one segment or the face code and size 
     1313      ;; should have been specified. 
     1314      (COND ((AND POINT-SIZE FACE-CODE) 
     1315             (DOLIST (SEG SEGMENT-DATA) 
     1316               (AND (STRING-EQUAL (CADR SEG) FACE-CODE) 
     1317                    (= (// (+ 1270. (* (FIFTH SEG) 72.)) 2540.) POINT-SIZE) 
     1318                    (RETURN (SETQ SEGMENT SEG)))) 
     1319             (OR SEGMENT (FERROR NIL "Font ~A not found in AC file" FONTNAME))) 
     1320            ((CDR SEGMENT-DATA) 
     1321             (FERROR "Font dictionary ~A: point size or face code not specified" FILENAME)) 
     1322            (T (SETQ SEGMENT (CAR SEGMENT-DATA) 
     1323                     POINT-SIZE (// (+ 1270. (* (FIFTH SEGMENT) 72.)) 2540.)))) 
     1324      (FUNCALL INPUT-FILE ':SET-POINTER (SEVENTH SEGMENT)) 
     1325      (LET ((BC (THIRD SEGMENT)) 
     1326            (EC (FOURTH SEGMENT)) 
     1327            (BASELINE 0) 
     1328            (XWIDTHS (MAKE-ARRAY 400)) 
     1329            (YWIDTHS (MAKE-ARRAY 400)) 
     1330            (BOX-X-OFFSET (MAKE-ARRAY 400)) 
     1331            (BOX-Y-OFFSET (MAKE-ARRAY 400)) 
     1332            (BOX-X-SIZE (MAKE-ARRAY 400)) 
     1333            (BOX-Y-SIZE (MAKE-ARRAY 400)) 
     1334            (CHAR-DATA-POSITION (MAKE-ARRAY 400)) 
     1335            LINE-HEIGHT) 
     1336        ;; read in the widths info from the segment. 
     1337        (DO ((I BC (1+ I))) ((> I EC)) 
     1338          (ASET (+ (SIGN-EXTEND (NEXT-WORD)) (// (NEXT-WORD) 65536.0)) 
     1339                XWIDTHS I) 
     1340          (ASET (+ (SIGN-EXTEND (NEXT-WORD)) (// (NEXT-WORD) 65536.0)) 
     1341                YWIDTHS I) 
     1342          (ASET (SIGN-EXTEND (NEXT-WORD)) BOX-X-OFFSET I) 
     1343          (ASET (SIGN-EXTEND (NEXT-WORD)) BOX-Y-OFFSET I) 
     1344          (ASET (SIGN-EXTEND (NEXT-WORD)) BOX-X-SIZE I) 
     1345          (ASET (SIGN-EXTEND (NEXT-WORD)) BOX-Y-SIZE I)) 
     1346        ;; Read relative pointers to character data beginnings 
     1347        ;; and convert them to absolute pointers within the file. 
     1348        (DO ((I BC (1+ I)) 
     1349             (STARTING-POSITION (FUNCALL INPUT-FILE ':READ-POINTER))) 
     1350            ((> I EC)) 
     1351          (SETF (AREF CHAR-DATA-POSITION I) 
     1352                (+ (LSH (NEXT-WORD) 32.) 
     1353                   (NEXT-WORD) 
     1354                   STARTING-POSITION))) 
     1355        (SETQ FONTNAME (STRING-APPEND (CDR (ASSQ FAMILY-CODE CODE-ALIST)) 
     1356                                      (FORMAT NIL "~D" POINT-SIZE) 
     1357                                      (OR (SECOND SEGMENT) ""))) 
     1358        (SETQ FONTNAME (INTERN (STRING-UPCASE FONTNAME) "FONTS")) 
     1359        (SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME 
     1360                                       MAKE-ARRAY (:LENGTH (1+ EC)))) 
     1361        (SETF (FD-FILL-POINTER FD) (1+ EC)) 
     1362        (SETF (FD-VERT-RESOLUTION FD) (NTH 9 SEGMENT)) 
     1363        (SETF (FD-HORIZ-RESOLUTION FD) (NTH 8 SEGMENT)) 
     1364        (SETF (FD-ROTATION FD) (NTH 5 SEGMENT)) 
     1365        (DO ((HEIGHT 0) 
     1366             (I BC (1+ I))) 
     1367            ((> I EC) 
     1368             (SETQ LINE-HEIGHT (+ HEIGHT BASELINE)) 
     1369             (SETF (FD-LINE-SPACING FD) LINE-HEIGHT) 
     1370             (SETF (FD-BLINKER-HEIGHT FD) LINE-HEIGHT) 
     1371             (SETF (FD-BASELINE FD) (- LINE-HEIGHT BASELINE))) 
     1372          (COND (( (AREF BOX-Y-SIZE I) -1) 
     1373                 (SETQ HEIGHT (MAX HEIGHT (+ (AREF BOX-Y-SIZE I) (AREF BOX-Y-OFFSET I)))))) 
     1374          (COND (( (AREF BOX-Y-SIZE I) -1) 
     1375                 (SETQ BASELINE (MAX BASELINE (- (AREF BOX-Y-OFFSET I))))))) 
     1376        (DO ((CH BC (1+ CH)) 
     1377             (CHAR-WIDTH) 
     1378             (RASTER-HEIGHT) 
     1379             (RASTER-WIDTH) 
     1380             (CHAR-Y-OFFSET) 
     1381             (WD) 
     1382             (CD)) 
     1383            ((> CH EC)) 
     1384          (COND (( (AREF BOX-Y-SIZE CH) -1) 
     1385                 (SETQ CHAR-WIDTH (AREF XWIDTHS CH)) 
     1386                 (SETQ RASTER-WIDTH (AREF BOX-X-SIZE CH)) 
     1387                 (SETQ RASTER-HEIGHT (AREF BOX-Y-SIZE CH)) 
     1388                 (SETQ CHAR-Y-OFFSET (AREF BOX-Y-OFFSET CH)) 
     1389                 (SETQ CD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (:TYPE ART-1B 
     1390                                                            :LENGTH (LIST LINE-HEIGHT 
     1391                                                                          RASTER-WIDTH)))) 
     1392                 (SETF (CD-CHAR-WIDTH CD) CHAR-WIDTH) 
     1393                 (SETF (CD-CHAR-VERT-WIDTH CD) (AREF YWIDTHS CH)) 
     1394                 (AND (= CH #\SP) (SETF (FD-SPACE-WIDTH FD) CHAR-WIDTH)) 
     1395                 (SETF (CD-CHAR-LEFT-KERN CD) (- (AREF BOX-X-OFFSET CH))) 
     1396                 ;; Store the CD in the font descriptor 
     1397                 (ASET CD FD CH) 
     1398                 ;; Verify that the relative pointer to this character's data was right. 
     1399                 (OR (= (AREF CHAR-DATA-POSITION CH) 
     1400                        (FUNCALL INPUT-FILE ':READ-POINTER)) 
     1401                     (FERROR NIL "Inconsistent character data pointer for character ~C" CH)) 
     1402                 ;; Skip a word of redundant info on raster height and width. 
     1403                 (LET ((TEM (NEXT-WORD))) 
     1404                   (OR (= TEM (DPB (// (+ RASTER-HEIGHT 17) 20) 1206 RASTER-WIDTH)) 
     1405                       (FERROR NIL 
     1406        "Inconsistent raster size data at front of character bits for character ~C" 
     1407                               CH))) 
     1408                 ;; Raster lines go vertically up, leftmost line first. 
     1409                 (DOTIMES (HPOS RASTER-WIDTH) 
     1410                   ;; Read in the next vertical scan line. 
     1411                   (DOTIMES (VPOS RASTER-HEIGHT) 
     1412                     ;; If wd is exhausted, get next word into wd 
     1413                     (COND ((ZEROP (\ VPOS 16.)) 
     1414                            (SETQ WD (NEXT-WORD)))) 
     1415                     (SETQ TEM (LDB 1701 (LSH WD (\ VPOS 16.)))) 
     1416                     (OR ( 
     1417 (+ VPOS BASELINE CHAR-Y-OFFSET) LINE-HEIGHT) 
     1418                         (ASET TEM CD 
     1419                               (- LINE-HEIGHT 1 (+ VPOS BASELINE CHAR-Y-OFFSET)) 
     1420                               HPOS))))))) 
     1421        ;; Set width of blinker and space fields from the space character. 
     1422        (SETF (FD-BLINKER-WIDTH FD) (FD-SPACE-WIDTH FD)) 
     1423        (OR (= (FUNCALL INPUT-FILE ':READ-POINTER) 
     1424               (+ (NTH 6 SEGMENT) (NTH 7 SEGMENT))) 
     1425            (FERROR NIL "Inconsistent data-length in index of AC file")) 
     1426        FD)))) 
     1427 
     1428;;; This returns in array units, which are from the upper-left corner 
     1429(DEFUN CD-RASTER-RANGE (CD) 
     1430  (DECLARE (RETURN-LIST MINX MINY MAXX MAXY)) 
     1431  (LOOP WITH HEIGHT = (ARRAY-DIMENSION-N 1 CD) 
     1432        AND WIDTH = (ARRAY-DIMENSION-N 2 CD) 
     1433        WITH MINX = WIDTH AND MINY = HEIGHT 
     1434        AND MAXX = 0 AND MAXY = 0 
     1435        FOR X FROM 0 BELOW WIDTH 
     1436        DO (LOOP FOR Y FROM 0 BELOW HEIGHT 
     1437                 WHEN (NOT (ZEROP (AREF CD Y X))) 
     1438                 DO (SETQ MINX (MIN MINX X) 
     1439                          MAXX (MAX MAXX (1+ X)) 
     1440                          MINY (MIN MINY Y) 
     1441                          MAXY (MAX MAXY (1+ Y)))) 
     1442        FINALLY (RETURN (MIN MINX MAXX) (MIN MINY MAXY) MAXX MAXY))) 
     1443 
     1444;Return how many rasters are empty (all 0) 
     1445;at the bottom of the character and at the top. 
     1446(DEFUN CD-UNUSED-RASTER-HEIGHT (CD) 
     1447  (DECLARE (RETURN-LIST BOTTOM TOP)) 
     1448  (LET* ((DIMS (ARRAY-DIMENSIONS CD)) 
     1449         BOTTOM TOP 
     1450         (HEIGHT (CAR DIMS)) 
     1451         (WIDTH (CADR DIMS))) 
     1452    (DOTIMES (I HEIGHT) 
     1453      (AND (DOTIMES (J WIDTH) 
     1454             (AND (NOT (ZEROP (AREF CD I J))) 
     1455                  (RETURN T))) 
     1456           (RETURN (SETQ TOP I)))) 
     1457    (DOTIMES (I HEIGHT) 
     1458      (AND (DOTIMES (J WIDTH) 
     1459             (AND (NOT (ZEROP (AREF CD (- HEIGHT I 1) J))) 
     1460                  (RETURN T))) 
     1461           (RETURN (SETQ BOTTOM I)))) 
     1462    (COND (TOP (VALUES BOTTOM TOP)) 
     1463          ;; Handle case where all data is empty. 
     1464          (T (VALUES HEIGHT 0))))) 
     1465 
     1466;Write an AC file from a Lisp machine font. 
     1467(DEFUN WRITE-FONT-INTO-AC (FONTNAME &OPTIONAL FILENAME) 
     1468  (MULTIPLE-VALUE (FONTNAME FILENAME) 
     1469    (GET-OUTPUT-FILENAME-AND-FONTNAME FONTNAME FILENAME "AC")) 
     1470  (LET ((FD (FONT-NAME-FONT-DESCRIPTOR FONTNAME))) 
     1471    (WRITE-FONT-DESCRIPTOR-INTO-AC FD FILENAME))) 
     1472 
     1473(DEFUN WRITE-FONT-DESCRIPTOR-INTO-AC (FD &OPTIONAL FILENAME 
     1474                                         &AUX FAMILY-NAME FACE-CODE POINT-SIZE BC EC) 
     1475  (SETQ FILENAME (GET-OUTPUT-FILENAME-FROM-FONT-DESCRIPTOR FD FILENAME "AC")) 
     1476  (SETF (VALUES FAMILY-NAME FACE-CODE POINT-SIZE) 
     1477        (PRESS:DECODE-FONT-NAME (STRING (FD-NAME FD)))) 
     1478  (WITH-OPEN-FILE (OUTPUT-FILE FILENAME '(:WRITE :FIXNUM)) 
     1479    (LET* ((FONT-LENGTH (ARRAY-ACTIVE-LENGTH FD)) 
     1480           UNUSED-TOP-RASTERS UNUSED-BOTTOM-RASTERS 
     1481           CHAR-DATA-SIZE-TABLE (TOTAL-DATA-SIZE 0)) 
     1482 
     1483      (AND (> FONT-LENGTH 400) 
     1484           (PROGN (SETQ FONT-LENGTH 400) 
     1485                  (CERROR T NIL NIL "Font contains codes above 377 which AC file cannot hold" 
     1486                          ))) 
     1487 
     1488      (SETQ UNUSED-TOP-RASTERS (MAKE-ARRAY FONT-LENGTH) 
     1489            UNUSED-BOTTOM-RASTERS (MAKE-ARRAY FONT-LENGTH)) 
     1490 
     1491      ;; Figure out range of chars to actually output. 
     1492      (DOTIMES (I FONT-LENGTH) 
     1493        (AND (AREF FD I) (RETURN (SETQ BC I)))) 
     1494      (DO ((I (1- FONT-LENGTH) (1- I))) 
     1495          ((MINUSP I)) 
     1496        (AND (AREF FD I) (RETURN (SETQ EC I)))) 
     1497 
     1498      ;; Precompute how much data each character is going to require. 
     1499      ;; Count number of words of rasters, plus 1 word of info before them. 
     1500      (SETQ CHAR-DATA-SIZE-TABLE (MAKE-ARRAY FONT-LENGTH)) 
     1501      (DOTIMES (CHAR-CODE FONT-LENGTH) 
     1502        (LET* ((CD (AREF FD CHAR-CODE)) 
     1503               (DATA-SIZE 0)) 
     1504          (AND CD 
     1505               (MULTIPLE-VALUE-BIND (TEM1 TEM2) 
     1506                   (CD-UNUSED-RASTER-HEIGHT CD) 
     1507                 (SETF (AREF UNUSED-BOTTOM-RASTERS CHAR-CODE) TEM1) 
     1508                 (SETF (AREF UNUSED-TOP-RASTERS CHAR-CODE) TEM2) 
     1509                 (SETQ DATA-SIZE (1+ (* (// (+ (- (ARRAY-DIMENSION-N 1 CD) TEM1 TEM2) 17) 20) 
     1510                                        (ARRAY-DIMENSION-N 2 CD)))))) 
     1511          (SETQ TOTAL-DATA-SIZE (+ TOTAL-DATA-SIZE DATA-SIZE)) 
     1512          (SETF (AREF CHAR-DATA-SIZE-TABLE CHAR-CODE) DATA-SIZE))) 
     1513      (SETQ TOTAL-DATA-SIZE (+ TOTAL-DATA-SIZE (* 10. (- EC BC -1)))) 
     1514      ;; Index entry type 1, 12. words long. 
     1515      (FUNCALL OUTPUT-FILE ':TYO (DPB 1 1404 12.)) 
     1516      ;; Family code - always 1, since we only write one family. 
     1517      (FUNCALL OUTPUT-FILE ':TYO 1) 
     1518      ;; Write the family name now. 
     1519      (DO ((I 0 (1+ I)) 
     1520           (LEN (STRING-LENGTH FAMILY-NAME)) 
     1521           (HIGH-BYTE (STRING-LENGTH FAMILY-NAME))) 
     1522          ((= I 19.)) 
     1523        (LET ((CH (IF (< I LEN) 
     1524                      (AREF FAMILY-NAME I) 
     1525                      0))) 
     1526          (IF HIGH-BYTE 
     1527              (PROGN (FUNCALL OUTPUT-FILE ':TYO 
     1528                              (DPB HIGH-BYTE 1010 CH)) 
     1529                     (SETQ HIGH-BYTE NIL)) 
     1530              (SETQ HIGH-BYTE CH)))) 
     1531      ;; Now write the index entry for the data segment. 
     1532      ;; Type 3, 11. words long. 
     1533      (FUNCALL OUTPUT-FILE ':TYO (DPB 3 1404 11.)) 
     1534      ;; Now family code and face code. 
     1535      (FUNCALL OUTPUT-FILE ':TYO (DPB 1 1010 (PRESS:ENCODE-PRESS-FACE FACE-CODE))) 
     1536      ;; Now range of characters actually existing in the font. 
     1537      (FUNCALL OUTPUT-FILE ':TYO (DPB BC 1010 EC)) 
     1538      ;; Now size of font. 
     1539      (FUNCALL OUTPUT-FILE ':TYO (// (+ (* POINT-SIZE 2540.) 36.) 72.)) 
     1540      ;; Rotation is 0. 
     1541      (FUNCALL OUTPUT-FILE ':TYO 0) 
     1542      ;; Position in file of start of data (2 words). 
     1543      (FUNCALL OUTPUT-FILE ':TYO 0) 
     1544      (FUNCALL OUTPUT-FILE ':TYO 24.) 
     1545      ;; Number of words of data. 
     1546      (FUNCALL OUTPUT-FILE ':TYO (LDB 2020 TOTAL-DATA-SIZE)) 
     1547      (FUNCALL OUTPUT-FILE ':TYO (LDB 0020 TOTAL-DATA-SIZE)) 
     1548      ;; Resolutions 
     1549      (FUNCALL OUTPUT-FILE ':TYO (FD-HORIZ-RESOLUTION FD)) 
     1550      (FUNCALL OUTPUT-FILE ':TYO (FD-VERT-RESOLUTION FD)) 
     1551      ;; Index entry type 0, end of index. 
     1552      (FUNCALL OUTPUT-FILE ':TYO 1) 
     1553      
     1554      ;; Output descriptions of the characters in the font. 
     1555      (DO ((CHAR-CODE BC (1+ CHAR-CODE))) 
     1556          ((> CHAR-CODE EC)) 
     1557        (LET ((CD (AREF FD CHAR-CODE))) 
     1558          (COND ((NULL CD) 
     1559                 (FUNCALL OUTPUT-FILE ':TYO 0) 
     1560                 (FUNCALL OUTPUT-FILE ':TYO 0) 
     1561                 (FUNCALL OUTPUT-FILE ':TYO 0) 
     1562                 (FUNCALL OUTPUT-FILE ':TYO 0) 
     1563                 (FUNCALL OUTPUT-FILE ':TYO 0) 
     1564                 (FUNCALL OUTPUT-FILE ':TYO 0) 
     1565                 (FUNCALL OUTPUT-FILE ':TYO 0) 
     1566                 (FUNCALL OUTPUT-FILE ':TYO -1)) 
     1567                (T 
     1568                 (FUNCALL OUTPUT-FILE ':TYO (FIX (CD-CHAR-WIDTH CD))) 
     1569                 (FUNCALL OUTPUT-FILE ':TYO 
     1570                          (FIX (* 65536. (- (CD-CHAR-WIDTH CD) (FIX (CD-CHAR-WIDTH CD)))))) 
     1571                 (FUNCALL OUTPUT-FILE ':TYO (FIX (CD-CHAR-VERT-WIDTH CD))) 
     1572                 (FUNCALL OUTPUT-FILE ':TYO 
     1573                          (FIX (* 65536. (- (CD-CHAR-VERT-WIDTH CD) 
     1574                                            (FIX (CD-CHAR-VERT-WIDTH CD)))))) 
     1575                 (FUNCALL OUTPUT-FILE ':TYO (- (CD-CHAR-LEFT-KERN CD))) 
     1576                 (FUNCALL OUTPUT-FILE ':TYO (+ (- (FD-BASELINE FD) 
     1577                                                  (FD-LINE-SPACING FD)) 
     1578                                               (AREF UNUSED-BOTTOM-RASTERS CHAR-CODE))) 
     1579                 (FUNCALL OUTPUT-FILE ':TYO (CADR (ARRAY-DIMENSIONS CD))) 
     1580                 (FUNCALL OUTPUT-FILE ':TYO (- (CAR (ARRAY-DIMENSIONS CD)) 
     1581                                               (AREF UNUSED-BOTTOM-RASTERS CHAR-CODE) 
     1582                                               (AREF UNUSED-TOP-RASTERS CHAR-CODE))))))) 
     1583      ;; Output offsets to data for each character. 
     1584      (LET* ((CURRENT-POS (+ 24. (* 8 (- EC BC -1)))) 
     1585             (EXPECTED-DATA-START 
     1586               (+ CURRENT-POS (* 2 (- EC BC -1))))) 
     1587        (DO ((CHAR-CODE BC (1+ CHAR-CODE))) 
     1588            ((> CHAR-CODE EC)) 
     1589          (LET ((OFFSET (- EXPECTED-DATA-START CURRENT-POS))) 
     1590            (FUNCALL OUTPUT-FILE ':TYO (LDB 2020 OFFSET)) 
     1591            (FUNCALL OUTPUT-FILE ':TYO (LDB 0020 OFFSET))) 
     1592          (SETQ EXPECTED-DATA-START 
     1593                (+ EXPECTED-DATA-START 
     1594                   (AREF CHAR-DATA-SIZE-TABLE CHAR-CODE))))) 
     1595       
     1596      ;; Now output the rasters themselves. 
     1597      (DO ((CHAR-CODE BC (1+ CHAR-CODE))) 
     1598          ((> CHAR-CODE EC)) 
     1599        (LET* (WD 
     1600               (CD (AREF FD CHAR-CODE))) 
     1601          (COND (CD 
     1602                 (LET* ((RASTER-WIDTH (ARRAY-DIMENSION-N 2 CD)) 
     1603                        (RASTER-BOTTOM-SKIP (AREF UNUSED-BOTTOM-RASTERS CHAR-CODE)) 
     1604                        (REAL-RASTER-HEIGHT (ARRAY-DIMENSION-N 1 CD)) 
     1605                        (RASTER-HEIGHT (- REAL-RASTER-HEIGHT 
     1606                                          RASTER-BOTTOM-SKIP 
     1607                                          (AREF UNUSED-TOP-RASTERS CHAR-CODE)))) 
     1608                   ;; Output redundant raster size info word. 
     1609                   (FUNCALL OUTPUT-FILE ':TYO 
     1610                            (DPB (// (+ RASTER-HEIGHT 17) 20) 
     1611                                 1206 
     1612                                 (ARRAY-DIMENSION-N 2 CD))) 
     1613                   ;; Raster lines go vertically up, leftmost line first. 
     1614                   (DOTIMES (HPOS RASTER-WIDTH) 
     1615                     (SETQ WD 0) 
     1616                     ;; Write the next vertical scan line. 
     1617                     (DOTIMES (VPOS RASTER-HEIGHT) 
     1618                       (SETQ WD (+ WD (LSH (AREF CD (- REAL-RASTER-HEIGHT 
     1619                                                       1 VPOS RASTER-BOTTOM-SKIP) 
     1620                                                 HPOS) 
     1621                                            
     1622                                           (- 17 (\ VPOS 20))))) 
     1623                       ;; If wd is full, output it. 
     1624                       (AND (ZEROP (\ (1+ VPOS) 16.)) 
     1625                            (PROGN (FUNCALL OUTPUT-FILE ':TYO WD) 
     1626                                   (SETQ WD 0)))) 
     1627                     ;; Output partially-filled word at end. 
     1628                     (OR (ZEROP (\ RASTER-HEIGHT 16.)) 
     1629                         (FUNCALL OUTPUT-FILE ':TYO WD))))))))) 
     1630    (FUNCALL OUTPUT-FILE ':CLOSE) 
     1631    (FUNCALL OUTPUT-FILE ':TRUENAME))) 
     1632 
     1633(DEFUN READ-AST-INTO-FONT (FILENAME &OPTIONAL FONTNAME) 
     1634  (MULTIPLE-VALUE (FILENAME FONTNAME) 
     1635    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AST")) 
     1636  (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME 
     1637                                     (READ-AST-INTO-FONT-DESCRIPTOR FILENAME FONTNAME)) 
     1638  FONTNAME) 
     1639 
     1640(DEFUN READ-AST-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME &AUX FD) 
     1641  (MULTIPLE-VALUE (FILENAME FONTNAME) 
     1642    (GET-INPUT-FILENAME-AND-FONTNAME FILENAME FONTNAME "AST")) 
     1643  (WITH-OPEN-FILE (STREAM FILENAME '(:IN)) 
     1644    (SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME MAKE-ARRAY (:LENGTH 200))) 
     1645    (READ-AST-DN STREAM)                        ;DISCARD KSTID 
     1646    (SETF (FD-LINE-SPACING FD) (READ-AST-DN STREAM)) 
     1647    (SETF (FD-BASELINE FD) (READ-AST-DN STREAM)) 
     1648    (READ-AST-DN STREAM)                        ;COLUMN POSITION ADJUSTMENT 
     1649    (SETF (FD-SPACE-WIDTH FD) 0)                ;Just in case no space character. 
     1650    (SETF (FD-BLINKER-HEIGHT FD) 
     1651          (FD-LINE-SPACING FD)) 
     1652    (SETF (FD-NAME FD) FONTNAME) 
     1653    (LET (KERN CHAR-CODE RASTER-WIDTH INPUT-RASTER-WIDTH CHAR-WIDTH 
     1654          CD CH (LINE-HEIGHT (FD-LINE-SPACING FD))) 
     1655      (DO () 
     1656          ((NULL (READ-AST-NEXT-PAGE STREAM))) 
     1657        (SETQ CHAR-CODE (READ-AST-ON STREAM)) 
     1658        (SETQ INPUT-RASTER-WIDTH (READ-AST-DN STREAM) RASTER-WIDTH INPUT-RASTER-WIDTH) 
     1659        (SETQ CHAR-WIDTH (READ-AST-DN STREAM)) 
     1660        (SETQ KERN (READ-AST-DN STREAM)) 
     1661        (COND ((< KERN 0)                       ;FED COMPACT RASTER LOSSAGE 
     1662               (SETQ RASTER-WIDTH (+ RASTER-WIDTH (ABS KERN))) 
     1663               (SETQ KERN 0))) 
     1664        (SETQ CD (MAKE-CHAR-DESCRIPTOR 
     1665                   MAKE-ARRAY (:TYPE ART-1B :LENGTH (LIST LINE-HEIGHT RASTER-WIDTH)))) 
     1666        (SETF (CD-CHAR-WIDTH CD) CHAR-WIDTH) 
     1667        (SETF (CD-CHAR-LEFT-KERN CD) KERN) 
     1668        (FD-STORE-CD FD CD CHAR-CODE) 
     1669        (AND (= CHAR-CODE #\SP) 
     1670             (SETF (FD-SPACE-WIDTH FD) CHAR-WIDTH)) 
     1671        (DO-NAMED TOP ((VPOS 0 (1+ VPOS))) 
     1672                  ((= VPOS LINE-HEIGHT)) 
     1673          (DO ((HCNT 0 (1+ HCNT))) 
     1674              ((= HCNT INPUT-RASTER-WIDTH) 
     1675               (DO ((CH)) () 
     1676                 (COND ((OR (NULL (SETQ CH (FUNCALL STREAM ':TYI))) 
     1677                            (= CH #\RETURN)) 
     1678                        (RETURN NIL)) 
     1679                       ((NOT (= CH #\SPACE)) 
     1680                        (FERROR NIL "non space seen past raster width"))))) 
     1681            (SETQ CH (FUNCALL STREAM ':TYI)) 
     1682            (COND ((NULL CH) 
     1683                   (RETURN-FROM TOP NIL)) 
     1684                  ((= CH #\FORM) 
     1685                   (FUNCALL STREAM ':UNTYI CH) 
     1686                   (RETURN-FROM TOP NIL)) 
     1687                  ((OR (< CH 40) (> CH 200)) 
     1688                   (DO () ((= CH #\RETURN)) (SETQ CH (FUNCALL STREAM ':TYI))) 
     1689                   (RETURN NIL)) 
     1690                  ((> CH 40) 
     1691                   (ASET 1 CD VPOS (+ HCNT (- RASTER-WIDTH INPUT-RASTER-WIDTH))))))) 
     1692     ; (COND ((> CHAR-CODE 37) (TYO CHAR-CODE)) 
     1693     ;        (T (PRINC '^) (TYO (+ 100 CHAR-CODE)))) 
     1694        ) 
     1695      ;; Truncate fd to discard unused elements at the end. 
     1696      (DO ((I (1- (ARRAY-LENGTH FD)) (1- I))) 
     1697          ((OR (MINUSP I) 
     1698               (AREF FD I)) 
     1699           (ADJUST-ARRAY-SIZE FD (1+ I)))) 
     1700      (SETF (FD-FILL-POINTER FD) (ARRAY-LENGTH FD)) 
     1701      ;; Set width of blinker and space fields from the space character. 
     1702      (SETF (FD-BLINKER-WIDTH FD) 
     1703            (FD-SPACE-WIDTH FD)) 
     1704      FD))) 
     1705 
     1706(DEFUN READ-AST-DN (STREAM) 
     1707  (PROG (N CH SIGN) 
     1708    (SETQ N 0 SIGN 1) 
     1709    (SETQ CH (FUNCALL STREAM ':TYI))            ;LOOK FOR MINUS SIGN 
     1710    (COND ((= CH #/-) 
     1711           (SETQ SIGN -1)) 
     1712          (T (GO AA))) 
     1713 A   (SETQ CH (FUNCALL STREAM ':TYI)) 
     1714 AA  (AND ( 
     1715 CH #/0) ( 
     1716 CH #/9) 
     1717          (PROGN 
     1718            (SETQ N (+ (* N 10.) (- CH #/0))) 
     1719            (GO A))) 
     1720 B   (AND (= CH #\RETURN) (RETURN (* N SIGN))) 
     1721    (SETQ CH (FUNCALL STREAM ':TYI)) 
     1722    (GO B))) 
     1723 
     1724(DEFUN READ-AST-ON (STREAM) 
     1725  (PROG (N CH) 
     1726    (SETQ N 0) 
     1727A   (SETQ CH (FUNCALL STREAM ':TYI)) 
     1728    (AND ( 
     1729 CH #/0) ( 
     1730 CH #/8) 
     1731         (PROGN 
     1732           (SETQ N (+ (* N 8) (- CH #/0))) 
     1733           (GO A))) 
     1734B   (AND (= CH #\RETURN) (RETURN N)) 
     1735    (SETQ CH (FUNCALL STREAM ':TYI)) 
     1736    (GO B))) 
     1737 
     1738(DEFUN READ-AST-NEXT-PAGE (STREAM) 
     1739  (PROG (CH) 
     1740    (COND ((NULL (SETQ CH (FUNCALL STREAM ':TYI))) (RETURN NIL)) 
     1741          ((= CH #\FORM) 
     1742           (SETQ CH (FUNCALL STREAM ':TYI)) 
     1743           (FUNCALL STREAM ':UNTYI CH) 
     1744           (IF (NULL CH) 
     1745               (RETURN NIL) 
     1746               (RETURN T))) 
     1747          (T (FERROR NIL "Random char where FF expected"))))) 
     1748 
     1749(DEFUN WRITE-FONT-INTO-AST (FONTNAME &OPTIONAL FILENAME) 
     1750  (MULTIPLE-VALUE (FONTNAME FILENAME) 
     1751    (GET-OUTPUT-FILENAME-AND-FONTNAME FONTNAME FILENAME "AST")) 
     1752  (LET ((FD (FONT-NAME-FONT-DESCRIPTOR FONTNAME))) 
     1753    (WRITE-FONT-DESCRIPTOR-INTO-AST FD FILENAME))) 
     1754 
     1755(DEFUN WRITE-FONT-DESCRIPTOR-INTO-AST (FD &OPTIONAL FILENAME 
     1756                                          &AUX (FONT-LENGTH (ARRAY-ACTIVE-LENGTH FD))) 
     1757  (SETQ FILENAME (GET-OUTPUT-FILENAME-FROM-FONT-DESCRIPTOR FD FILENAME "AST")) 
     1758  (WITH-OPEN-FILE (STREAM FILENAME '(:OUT :ASCII)) 
     1759    (FORMAT STREAM "0 KSTID ~A"  FILENAME) 
     1760    (FORMAT STREAM "~%~D HEIGHT" (FD-LINE-SPACING FD)) 
     1761    (FORMAT STREAM "~%~D BASE LINE" (FD-BASELINE FD)) 
     1762    (FORMAT STREAM "~%0 COLUMN POSITION ADJUSTMENT~%") 
     1763    ;; Then write out all the characters. 
     1764    (LET (CD CHAR-HEIGHT) 
     1765      (DOTIMES (CHAR-CODE FONT-LENGTH) 
     1766        (COND ((AND (SETQ CD (AREF FD CHAR-CODE)) 
     1767                      ;; Wide fonts without chars-exist-tables can have 0-width chars. 
     1768                    (OR (NOT (ZEROP (ARRAY-DIMENSION-N 2 CD))) 
     1769                        (NOT (ZEROP (CD-CHAR-WIDTH CD))))) 
     1770               (FUNCALL STREAM ':TYO #\FORM) 
     1771               (FORMAT STREAM "~O CHARACTER CODE ~A" CHAR-CODE FILENAME) 
     1772               (FORMAT STREAM "~%~D RASTER WIDTH" (ARRAY-DIMENSION-N 2 CD)) 
     1773               (FORMAT STREAM "~%~D CHARACTER WIDTH" (CD-CHAR-WIDTH CD)) 
     1774               (FORMAT STREAM "~%~D LEFT KERN~%" (CD-CHAR-LEFT-KERN CD)) 
     1775               (SETQ CHAR-HEIGHT (ARRAY-DIMENSION-N 1 CD)) 
     1776               (DOTIMES (VPOS CHAR-HEIGHT) 
     1777                 (DOTIMES (HPOS (ARRAY-DIMENSION-N 2 CD)) 
     1778                   (FUNCALL STREAM ':TYO (IF (ZEROP (AREF CD VPOS HPOS)) 
     1779                                             #\SPACE 
     1780                                             #/*))) 
     1781                 (FUNCALL STREAM ':TYO #\RETURN)))))) 
     1782    (FUNCALL STREAM ':CLOSE) 
     1783    (FUNCALL STREAM ':TRUENAME))) 
     1784 
  • 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;;; Routines for building Press pages and shipping them out an EFTP connection 
     
    3248;;; Later this might be made into a more stream-like thing (as a "resource") 
    3349 
    34 (DEFVAR PRESS-EFTP-STREAM)                      ;EFTP connection we send through 
    35 (DEFVAR PRESS-N-CHARS)                          ;Number of characters sent this part 
    36 (DEFVAR PRESS-CURRENT-RECORD-NUMBER)            ;Record number within file 
    37 (DEFVAR PRESS-X)                                ;X position computed as characters sent 
    38 (DEFVAR PRESS-Y)                                ;Y .. 
    39 (DEFVAR PRESS-PAGE-NUMBER)                      ;Serial number of page 
    40 (DEFVAR PRESS-END-PAGE-HOOK   NIL)              ;If non-NIL, function to call 
    41 (DEFVAR PRESS-PENDING-CHARS)                    ;Number of chars output but not yet known 
     50(DEFINE-PRESS-VARIABLE PRESS-INTERPRET-XGP-ESCAPE NIL)  ;177 is special character in input 
     51(DEFINE-PRESS-VARIABLE PRESS-EFTP-STREAM NIL)   ;EFTP connection we send through 
     52(DEFINE-PRESS-VARIABLE PRESS-N-CHARS)           ;Number of characters sent this part 
     53(DEFINE-PRESS-VARIABLE PRESS-CURRENT-RECORD-NUMBER 0)   ;Record number within file 
     54(DEFINE-PRESS-VARIABLE PRESS-X)                 ;X position computed as characters sent 
     55(DEFINE-PRESS-VARIABLE PRESS-Y)                 ;Y .. 
     56(DEFINE-PRESS-VARIABLE PRESS-BASELINE-Y)        ;Baseline Y, usually the same 
     57(DEFINE-PRESS-VARIABLE PRESS-INTERCHAR-SPACING NIL)     ;Between all chars if non-NIL 
     58(DEFINE-PRESS-VARIABLE PRESS-INTERLINE-SPACING NIL)     ;Between all lines if non-NIL 
     59(DEFINE-PRESS-VARIABLE PRESS-PAGE-NUMBER 1)     ;Serial number of page 
     60(DEFINE-PRESS-VARIABLE PRESS-END-PAGE-HOOK NIL) ;If non-NIL, function to call 
     61(DEFINE-PRESS-VARIABLE PRESS-PENDING-CHARS)     ;Number of chars output but not yet known 
    4262                                                ;about at the "entity" level 
    4363 
    44 (DEFVAR PRESS-DATA-LIST-START)                  ;Value of PRESS-N-CHARS at start of entity 
    45 (DEFVAR PRESS-ENTITY-LIST-START)                ;Value of (size of entity buffer) at .. 
     64(DEFINE-PRESS-VARIABLE PRESS-DATA-LIST-START)   ;Value of PRESS-N-CHARS at start of entity 
     65(DEFINE-PRESS-VARIABLE PRESS-ENTITY-LIST-START) ;Value of (size of entity buffer) at .. 
    4666 
    4767(DEFVAR PRESS-PAGE-ENTITY-BUFFER-EXTENSION-SIZE 4000.) 
    48 (DEFVAR PRESS-PAGE-ENTITY-BUFFER 
    49         (MAKE-ARRAY NIL 'ART-8B PRESS-PAGE-ENTITY-BUFFER-EXTENSION-SIZE NIL '(0))) 
     68(DEFRESOURCE PRESS-PAGE-ENTITY-BUFFER () 
     69  :CONSTRUCTOR (MAKE-ARRAY PRESS-PAGE-ENTITY-BUFFER-EXTENSION-SIZE 
     70                           ':TYPE 'ART-8B 
     71                           ':LEADER-LIST '(0))) 
     72(DEFINE-PRESS-VARIABLE PRESS-PAGE-ENTITY-BUFFER (ALLOCATE-RESOURCE 'PRESS-PAGE-ENTITY-BUFFER)) 
    5073                                                ;This holds the "entity" portion of the 
    5174                                                ;current page 
    5275 
    53 (DEFVAR PRESS-PART-LIST) ;List of elements (part-type record-number n-records n-padding-words) 
    54 (DEFVAR PRESS-FONT-LIST) ;List of elements (family-name face-name point-size rotation 
    55                          ;                  width height width-table) 
    56 (DEFVAR PRESS-CURRENT-FONT NIL)                 ;Element for selected font 
    57  
    58 (DEFVAR DOVER-X0 2000.)                         ;2 cm left margin 
    59 (DEFVAR DOVER-Y0 (FIX (* 9.8 2540.)))           ;Where the page number goes 
    60 (DEFVAR DOVER-Y1 (FIX (* 9.5 2540.)))           ;Where the text starts 
    61 (DEFVAR DOVER-Y2 (FIX (* 0.5 2540.)))           ;Margin at the bottom of the page 
    62 (DEFVAR LINE-WIDTH 25.)                         ;Line width .01 inch 
     76(DEFINE-PRESS-VARIABLE PRESS-PART-LIST NIL)     ;List of elements (part-type record-number 
     77                                                ;                  n-records n-padding-words) 
     78(DEFINE-PRESS-VARIABLE PRESS-FONT-LIST NIL)     ;List of elements (family-name face-name 
     79                                                ;                  point-size rotation 
     80                                                ;                  width height width-table) 
     81(DEFINE-PRESS-VARIABLE PRESS-CURRENT-FONT NIL)  ;Element for selected font 
     82 
     83(DEFINE-PRESS-VARIABLE DOVER-X0 2000.)          ;2 cm left margin 
     84(DEFINE-PRESS-VARIABLE DOVER-Y0 (FIX (* 9.8 2540.)))    ;Where the page number goes 
     85(DEFINE-PRESS-VARIABLE DOVER-Y1 (FIX (* 9.5 2540.)))    ;Where the text starts 
     86(DEFINE-PRESS-VARIABLE DOVER-Y2 (FIX (* 0.5 2540.)))    ;Margin at the bottom of the page 
     87(DEFINE-PRESS-VARIABLE LINE-WIDTH 25.)          ;Line width .01 inch 
    6388;(DEFVAR DIAGONAL-LINE-WIDTH 18.)               ;Make darkness come out even 
    6489;This provides nice thin lines, for thinner lines you might want 2 instead of 4 
     
    78103;       226-232    The 1.-bit box 
    79104;       240        The 0-bit box (or isolated point). 
     105 
     106(DEFINE-PRESS-VARIABLE PRESS-XGP-UNDERLINE-START-X) 
     107(DEFINE-PRESS-VARIABLE PRESS-XGP-FONT-LIST NIL) 
    80108 
    81109;;;; Output to the Data and Entity Lists 
     
    196224 
    197225(DEFUN PRESS-START-FILE (&OPTIONAL (HOST-ADDRESS DOVER-ADDRESS)) 
    198   (FS:FILE-BIND-DEFAULTS 
    199     (OR (FBOUNDP 'LOAD-FONT-WIDTHS) (LOAD "AI:LMIO1;RFONTW QFASL")) 
    200     (OR (BOUNDP 'FONT-WIDTH-DATA) (LOAD-FONT-WIDTHS)) 
    201     (SETQ PRESS-EFTP-STREAM 
    202           (IF (NUMBERP HOST-ADDRESS) 
    203               (IF PRESS-USE-EFTP (CHAOS:MAKE-EFTP-WRITE-STREAM HOST-ADDRESS T) 
    204                   (LET ((CONN (CHAOS:CONNECT 426 "DOVER"))) 
    205                     (AND (STRINGP CONN) 
    206                          (FERROR NIL 
    207                                  "~A - cannot connect to DOVER server at AI-CHAOS-11" CONN)) 
    208                     (CHAOS:STREAM CONN))) 
    209               (OPEN (SI:FILE-PARSE-NAME 
    210                       HOST-ADDRESS NIL 
    211                       (SI:FILE-PARSE-NAME (FORMAT NIL "MC:.DOVR.;~A >" USER-ID))) 
    212                     '(:WRITE :FIXNUM :BYTE-SIZE 8))) 
    213           PRESS-CURRENT-RECORD-NUMBER 0 
    214           PRESS-PART-LIST NIL 
    215           PRESS-FONT-LIST NIL                   ;this is a crock *** 
    216           PRESS-PAGE-NUMBER 1 
    217           ))) 
    218  
     226  (OR (BOUNDP 'FONT-WIDTH-DATA) 
     227      (LOAD-FONT-WIDTHS "SYS: PRESS-FONTS; FONTS WIDTHS >")) 
     228  (SETQ PRESS-EFTP-STREAM (PRESS-OPEN-EFTP-STREAM HOST-ADDRESS DOVER-ADDRESS))) 
     229 
     230(DEFUN PRESS-OPEN-EFTP-STREAM (HOST-ADDRESS DOVER-ADDRESS) 
     231  (IF (NUMBERP HOST-ADDRESS) 
     232      (IF PRESS-USE-EFTP (CHAOS:MAKE-EFTP-WRITE-STREAM HOST-ADDRESS T) 
     233          (LET ((CONN (CHAOS:CONNECT "AI-CHAOS-11" "DOVER"))) 
     234            (AND (STRINGP CONN) 
     235                 (FERROR NIL 
     236                         "~A - cannot connect to DOVER server at AI-CHAOS-11" CONN)) 
     237            (CHAOS:STREAM CONN))) 
     238      (OPEN HOST-ADDRESS '(:WRITE :FIXNUM :BYTE-SIZE 8)))) 
    219239 
    220240;;;; Finish Press File 
     
    273293  (FUNCALL PRESS-EFTP-STREAM ':STRING-OUT PRESS-PAGE-ENTITY-BUFFER) 
    274294  (PRESS-FINISH-PART (ARRAY-LEADER PRESS-PAGE-ENTITY-BUFFER 0) 1) 
    275   ;; Except for :CLOSE itself this is superfluous except 
    276   ;; when going through the AI-CHAOS-11 dover server 
    277   (AND (MEMQ ':EOF (FUNCALL PRESS-EFTP-STREAM ':WHICH-OPERATIONS)) 
    278        (FUNCALL PRESS-EFTP-STREAM ':EOF)) 
    279   (FUNCALL PRESS-EFTP-STREAM ':CLOSE)) 
     295  (FUNCALL PRESS-EFTP-STREAM ':CLOSE) 
     296  (FUNCALL PRESS-EFTP-STREAM ':SEND-IF-HANDLES ':TRUENAME)) 
    280297 
    281298;;;; Pages 
     
    347364;Finish the current entity.  You can start another if you like. 
    348365(DEFUN PRESS-CLOSE-ENTITY (&OPTIONAL (X-OFF DOVER-X0) (Y-OFF DOVER-Y2) 
    349                                      (WIDTH (*  8. 2540.)) (HEIGHT (* 11. 2540.))) 
     366                                     (WIDTH (*  85. 254.)) (HEIGHT (* 11. 2540.))) 
    350367  (PRESS-PUT-PENDING-CHARS) 
    351368  ;; Pad entity to word boundary with NOP 
     
    424441                                      (THIRD PRESS-CURRENT-FONT) 
    425442                                      (SECOND PRESS-CURRENT-FONT)) 
    426                (SETQ PRESS-X (+ WIDTH PRESS-X))))) 
     443               (SETQ PRESS-X (+ WIDTH PRESS-X)))) 
     444         (AND PRESS-INTERCHAR-SPACING 
     445              (PRESS-SET-CURSOR (+ PRESS-X PRESS-INTERCHAR-SPACING) PRESS-Y))) 
    427446        ((= CHAR #\TAB) 
    428447         ;; The bounding box seems to be wedged, it's not the same as the character 
     
    431450           (PRESS-SET-CURSOR (* (1+ (// PRESS-X TAB-WIDTH)) TAB-WIDTH) PRESS-Y))) 
    432451        ((= CHAR #\CR) 
    433          (LET ((Y (- PRESS-Y (SIXTH PRESS-CURRENT-FONT)))) 
     452         (LET ((Y (- PRESS-Y (OR PRESS-INTERLINE-SPACING (SIXTH PRESS-CURRENT-FONT))))) 
    434453           (IF (MINUSP Y) (PRESS-CHAR #\FORM) 
    435                (PRESS-SET-CURSOR 0 Y)))) 
     454               (PRESS-SET-CURSOR 0 Y))) 
     455         (SETQ PRESS-BASELINE-Y PRESS-Y 
     456               PRESS-INTERCHAR-SPACING NIL)) 
    436457        ((= CHAR #\FORM) 
    437458         (PRESS-END-PAGE) 
    438          (PRESS-START-PAGE))) 
     459         (PRESS-START-PAGE) 
     460         (SETQ PRESS-INTERCHAR-SPACING NIL))) 
    439461  NIL) 
    440462 
     
    454476;Add a font to the font set and return its font number 
    455477(DEFUN PRESS-DEFINE-FONT (FAMILY-NAME FACE-NAME POINT-SIZE ROTATION) 
    456   (LET ((WIDTH (GET-FONT-WIDTH-AND-HEIGHT FAMILY-NAME FACE-NAME POINT-SIZE)) 
    457         HEIGHT WIDTH-ARRAY FONT-DESC FONT-NUMBER) 
    458     (SETQ HEIGHT (CADR WIDTH) WIDTH (CAR WIDTH))        ;Bounding box for font 
    459     (SETQ WIDTH-ARRAY (GET-FONT-WIDTH-DATA FAMILY-NAME FACE-NAME POINT-SIZE)) 
    460     (SETQ FONT-DESC (LIST FAMILY-NAME FACE-NAME POINT-SIZE ROTATION 
    461                           WIDTH HEIGHT WIDTH-ARRAY)) 
    462     (OR (MEMBER FONT-DESC PRESS-FONT-LIST) 
    463         (SETQ PRESS-FONT-LIST (NCONC PRESS-FONT-LIST (NCONS FONT-DESC)))) 
    464     (SETQ FONT-NUMBER (FIND-POSITION-IN-LIST-EQUAL FONT-DESC PRESS-FONT-LIST)) 
    465     (AND ( 
     478  (OR (PRESS-LOOKUP-FONT FAMILY-NAME FACE-NAME POINT-SIZE ROTATION) 
     479      (LET ((WIDTH (GET-FONT-WIDTH-AND-HEIGHT FAMILY-NAME FACE-NAME POINT-SIZE)) 
     480            HEIGHT WIDTH-ARRAY FONT-DESC FONT-NUMBER) 
     481        (SETQ HEIGHT (CADR WIDTH) WIDTH (CAR WIDTH))    ;Bounding box for font 
     482        (SETQ WIDTH-ARRAY (GET-FONT-WIDTH-DATA FAMILY-NAME FACE-NAME POINT-SIZE)) 
     483        (SETQ FONT-DESC (LIST FAMILY-NAME FACE-NAME POINT-SIZE ROTATION 
     484                              WIDTH HEIGHT WIDTH-ARRAY)) 
     485        (SETQ PRESS-FONT-LIST (NCONC PRESS-FONT-LIST (NCONS FONT-DESC))) 
     486        (SETQ FONT-NUMBER (1- (LENGTH PRESS-FONT-LIST))) 
     487        (AND ( 
    466488 FONT-NUMBER 16.) (FERROR NIL "Maximum of 16 fonts allowed.")) 
    467     FONT-NUMBER)) 
     489        FONT-NUMBER))) 
    468490 
    469491;Similar to above, but works when there is no Fonts Widths data.  The 
     
    472494;Second value is T if font not found in Fonts Widths. 
    473495(DEFUN PRESS-DEFINE-FONT-FAKE (FAMILY-NAME FACE-NAME POINT-SIZE ROTATION) 
    474   (IF (ERRSET (FIND-FONT-DATA FAMILY-NAME FACE-NAME POINT-SIZE) NIL) 
    475       (PRESS-DEFINE-FONT FAMILY-NAME FACE-NAME POINT-SIZE ROTATION) 
    476       (LET ((WIDTH 633.) (HEIGHT 698.) WIDTH-ARRAY FONT-DESC FONT-NUMBER) 
    477         (SETQ WIDTH-ARRAY (MAKE-ARRAY NIL 'ART-16B 400)) 
    478         (FILLARRAY WIDTH-ARRAY '(633.)) 
    479         (SETQ FONT-DESC (LIST FAMILY-NAME FACE-NAME POINT-SIZE ROTATION 
    480                               WIDTH HEIGHT WIDTH-ARRAY)) 
    481         (OR (MEMBER FONT-DESC PRESS-FONT-LIST) 
    482             (SETQ PRESS-FONT-LIST (NCONC PRESS-FONT-LIST (NCONS FONT-DESC)))) 
    483         (SETQ FONT-NUMBER (FIND-POSITION-IN-LIST-EQUAL FONT-DESC PRESS-FONT-LIST)) 
    484         (AND ( 
     496  (OR (PRESS-LOOKUP-FONT FAMILY-NAME FACE-NAME POINT-SIZE ROTATION) 
     497      (IF (ERRSET (FIND-FONT-DATA FAMILY-NAME FACE-NAME POINT-SIZE) NIL) 
     498          (PRESS-DEFINE-FONT FAMILY-NAME FACE-NAME POINT-SIZE ROTATION) 
     499          (LET ((WIDTH 633.) (HEIGHT 698.) WIDTH-ARRAY FONT-DESC FONT-NUMBER) 
     500            (SETQ WIDTH-ARRAY (MAKE-ARRAY NIL 'ART-16B 400)) 
     501            (FILLARRAY WIDTH-ARRAY '(633.)) 
     502            (SETQ FONT-DESC (LIST FAMILY-NAME FACE-NAME POINT-SIZE ROTATION 
     503                                  WIDTH HEIGHT WIDTH-ARRAY)) 
     504            (SETQ PRESS-FONT-LIST (NCONC PRESS-FONT-LIST (NCONS FONT-DESC))) 
     505            (SETQ FONT-NUMBER (1- (LENGTH PRESS-FONT-LIST))) 
     506            (AND ( 
    485507 FONT-NUMBER 16.) (FERROR NIL "Maximum of 16 fonts allowed.")) 
    486         (PROG () (RETURN FONT-NUMBER T))))) 
     508            (PROG () (RETURN FONT-NUMBER T)))))) 
     509 
     510;Find position of font in PRESS-FONT-LIST 
     511(DEFUN PRESS-LOOKUP-FONT (FAMILY FACE POINT-SIZE ROTATION) 
     512  (DO ((L PRESS-FONT-LIST (CDR L)) 
     513       (I 0 (1+ I))) 
     514      ((NULL L)) 
     515    (AND (EQUAL FAMILY (CAAR L)) 
     516         (EQUAL FACE (SECOND (CAR L))) 
     517         (EQUAL POINT-SIZE (THIRD (CAR L))) 
     518         (EQUAL ROTATION (FOURTH (CAR L))) 
     519         (RETURN I)))) 
    487520 
    488521;Select a font, by number 
     
    518551 
    519552(DEFUN PRESS-ENTITY-BCPL-STRING (STRING NBYTES &AUX REAL-LENGTH) 
     553  (SETQ STRING (STRING STRING)) 
    520554  (PRESS-ENTITY-BYTE (SETQ REAL-LENGTH (MIN (STRING-LENGTH STRING) (1- NBYTES)))) 
    521555  (DOTIMES (I REAL-LENGTH) 
     
    525559 
    526560 
     561(DEFVAR PRESS-LINE-USE-SPECIAL-OPCODE NIL) 
    527562(DEFVAR NEWVEC-SLOPE-TABLE) 
    528563(DEFVAR NEWVEC-DX-TABLE) 
     
    558593  (PRESS-PUT-PENDING-CHARS) 
    559594  (PRESS-MAYBE-NEW-ENTITY)                      ;This should make DPLT work better 
    560   (COND ((= X0 X1)                              ;Vertical line 
     595  (COND (PRESS-LINE-USE-SPECIAL-OPCODE 
     596         (PRESS-SET-CURSOR X0 Y0) 
     597         (PRESS-ENTITY-BYTE 201) 
     598         (PRESS-ENTITY-WORD X1) 
     599         (PRESS-ENTITY-WORD Y1))          
     600        ((= X0 X1)                              ;Vertical line 
    561601         (PRESS-SET-CURSOR (- X0 (// LINE-WIDTH 2)) (MIN Y0 Y1))        ;Lower left corner 
    562602         (PRESS-SHOW-RECT LINE-WIDTH DY)) 
     
    673713;;;; Print a file 
    674714 
    675 (DEFUN PRINT-FILE (FILE-NAME &OPTIONAL (FONT-NAME "TIMESROMAN") 
     715(DEFUN PRINT-PRESS-FILE (FILE-NAME &REST OPTIONS) 
     716  (WITH-OPEN-FILE (INPUT-STREAM FILE-NAME) 
     717    (WITH-OPEN-STREAM (OUTPUT-STREAM (BIND-PRESS-VARIABLES 
     718                                       (MULTIPLE-VALUE-BIND (NIL NIL NIL NIL NIL 
     719                                                             HOST-ADDRESS) 
     720                                           (PRESS-DECODE-OPTIONS OPTIONS) 
     721                                         (PRESS-OPEN-EFTP-STREAM HOST-ADDRESS)))) 
     722      (STREAM-COPY-UNTIL-EOF INPUT-STREAM OUTPUT-STREAM) 
     723      (CLOSE OUTPUT-STREAM) 
     724      (FUNCALL OUTPUT-STREAM ':SEND-IF-HANDLES ':TRUENAME)))) 
     725 
     726(DEFUN PRINT-FILE (FILE-NAME &REST OPTIONS) 
     727  (WITH-OPEN-FILE (STREAM FILE-NAME '(:READ)) 
     728    (LEXPR-FUNCALL #'PRINT-FROM-STREAM 
     729                   STREAM (FUNCALL STREAM ':TRUENAME) OPTIONS))) 
     730 
     731(DEFUN SPOOL-FILE (FILE-NAME &REST OPTIONS) 
     732  (WITH-OPEN-FILE (STREAM FILE-NAME '(:READ)) 
     733    (LEXPR-FUNCALL #'PRINT-FROM-STREAM 
     734                   STREAM (FUNCALL STREAM ':TRUENAME) ':SPOOL T OPTIONS))) 
     735 
     736(DEFUN PRINT-FROM-STREAM (INPUT-STREAM FILE-NAME &REST OPTIONS 
     737                          &AUX CREATION-DATE FONT-NAME FACE-NAME FONT-SIZE PAGE-HEADINGS 
     738                               N-COPIES HOST-ADDRESS) 
     739  (DECLARE (SPECIAL FILE-NAME CREATION-DATE)) 
     740  (BIND-PRESS-VARIABLES 
     741    (MULTIPLE-VALUE (FONT-NAME FACE-NAME FONT-SIZE PAGE-HEADINGS N-COPIES HOST-ADDRESS) 
     742      (PRESS-DECODE-OPTIONS OPTIONS)) 
     743    (IF (MEMQ ':CREATION-DATE (FUNCALL INPUT-STREAM ':WHICH-OPERATIONS)) 
     744        (SETQ CREATION-DATE (FUNCALL INPUT-STREAM ':CREATION-DATE)) 
     745        (SETQ CREATION-DATE (TIME:GET-UNIVERSAL-TIME))) 
     746    (SETQ CREATION-DATE (TIME:PRINT-UNIVERSAL-TIME CREATION-DATE NIL)) 
     747    (IF PAGE-HEADINGS 
     748        (SETQ PRESS-END-PAGE-HOOK 
     749              #'(LAMBDA () 
     750                  (FORMAT T "~D " PRESS-PAGE-NUMBER) 
     751                  (PRESS-SET-CURSOR 0 DOVER-Y0) 
     752                  (PRESS-STRING (FORMAT NIL "~A~10X~A" FILE-NAME CREATION-DATE)) 
     753                  (PRESS-SET-CURSOR 15000. DOVER-Y0) 
     754                  (PRESS-STRING (FORMAT NIL "Page ~D" PRESS-PAGE-NUMBER)))) 
     755        (SETQ PRESS-END-PAGE-HOOK 
     756              #'(LAMBDA () (FORMAT T "~D " PRESS-PAGE-NUMBER)))) 
     757    (FORMAT T "~&~A:  " FILE-NAME) 
     758    (UNWIND-PROTECT 
     759      (PROGN (PRESS-START-FILE HOST-ADDRESS) 
     760             (AND PRESS-INTERPRET-XGP-ESCAPE 
     761                 (PRESS-XGP-HEADER-PAGE INPUT-STREAM)) 
     762             (PRESS-START-PAGE) 
     763             (PRESS-SELECT-FONT (IF PRESS-INTERPRET-XGP-ESCAPE 0 
     764                                    (PRESS-DEFINE-FONT FONT-NAME FACE-NAME FONT-SIZE 0))) 
     765             (DO ((CH)) 
     766                 ((NULL (SETQ CH (FUNCALL INPUT-STREAM ':TYI)))) 
     767               (IF (AND PRESS-INTERPRET-XGP-ESCAPE (= CH 177)) 
     768                   (PRESS-XGP-ESCAPE INPUT-STREAM) 
     769                   (PRESS-CHAR CH))) 
     770             (PRESS-END-PAGE) 
     771             (PRESS-END-FILE FILE-NAME CREATION-DATE N-COPIES 
     772                             (COND ((AND FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST 
     773                                         (NOT (EQUAL FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST 
     774                                                     ""))) 
     775                                    (FORMAT NIL "~A (~A)" USER-ID 
     776                                            FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST)) 
     777                                   (T USER-ID)))) 
     778      (AND PRESS-EFTP-STREAM 
     779           (NOT (STRINGP PRESS-EFTP-STREAM)) 
     780           (FUNCALL PRESS-EFTP-STREAM ':CLOSE ':ABORT))))) 
     781 
     782(DEFUN PRESS-DECODE-OPTIONS (OPTIONS &AUX (FONT-NAME "LPT") 
    676783                             (FACE-NAME "") 
    677                              (FONT-SIZE 10.) 
     784                             (FONT-SIZE 8) 
    678785                             (PAGE-HEADINGS T) 
    679786                             (N-COPIES 1) 
    680                              (SEND-TO-MOONS-ALTO-P NIL) 
    681                              (HOST-ADDRESS DOVER-ADDRESS) 
    682                              &AUX INPUT-STREAM (PRESS-USE-EFTP PRESS-USE-EFTP)) 
    683   (AND SEND-TO-MOONS-ALTO-P (SETQ PRESS-USE-EFTP T)) 
    684   (UNWIND-PROTECT  
    685     (LOCAL-DECLARE ((SPECIAL FILE-NAME CREATION-DATE)) 
    686       (SETQ INPUT-STREAM (OPEN FILE-NAME ':READ)) 
    687       (LET ((FILE-NAME (FUNCALL INPUT-STREAM ':GET ':UNIQUE-ID)) 
    688             (CREATION-DATE (FORMAT NIL "~A ~A" (FUNCALL INPUT-STREAM ':GET ':CREATION-DATE) 
    689                                    (FUNCALL INPUT-STREAM ':GET ':CREATION-TIME))) 
    690             (PRESS-END-PAGE-HOOK 
    691               (IF PAGE-HEADINGS 
    692                   #'(LAMBDA () 
    693                       (FORMAT T " page ~D " PRESS-PAGE-NUMBER) 
    694                       (PRESS-SET-CURSOR 0 DOVER-Y0) 
    695                       (PRESS-STRING (FORMAT NIL "~A~10X~A" FILE-NAME CREATION-DATE)) 
    696                       (PRESS-SET-CURSOR 15000. DOVER-Y0) 
    697                       (PRESS-STRING (FORMAT NIL "Page ~D" PRESS-PAGE-NUMBER))) 
    698                   #'(LAMBDA () 
    699                       (FORMAT T " page ~D " PRESS-PAGE-NUMBER))))) 
    700         (OR SEND-TO-MOONS-ALTO-P (STRINGP HOST-ADDRESS) (PRINT-DOVER-STATUS)) 
    701         (PRESS-START-FILE (IF SEND-TO-MOONS-ALTO-P 926-ALTO-ADDRESS HOST-ADDRESS)) 
    702         (PRESS-START-PAGE) 
    703         (PRESS-SELECT-FONT (PRESS-DEFINE-FONT FONT-NAME FACE-NAME FONT-SIZE 0)) 
    704         (DO ((CH (FUNCALL INPUT-STREAM ':TYI) (FUNCALL INPUT-STREAM ':TYI))) 
    705             ((NULL CH)) 
    706           (PRESS-CHAR CH)) 
    707         (PRESS-END-PAGE) 
    708         (PRESS-END-FILE FILE-NAME CREATION-DATE N-COPIES))) 
    709     (CLOSE INPUT-STREAM))) 
    710  
    711 ;Spool a file via MC's spooler 
    712 (DEFUN SPOOL-FILE (FILE-NAME &OPTIONAL (FONT-NAME "TIMESROMAN") 
    713                              (FACE-NAME "") 
    714                              (FONT-SIZE 10.) 
    715                              (PAGE-HEADINGS T) 
    716                              (N-COPIES 1) 
    717                              (FILE (FORMAT NIL "MC:.DOVR.;~A >" USER-ID))) 
    718   (PRINT-FILE FILE-NAME FONT-NAME FACE-NAME FONT-SIZE PAGE-HEADINGS N-COPIES NIL FILE)) 
    719  
     787                             (HOST-ADDRESS DOVER-ADDRESS)) 
     788  ;; Special variables are just set rather than returned 
     789  (DECLARE (RETURN-LIST FONT-NAME FACE-NAME FONT-SIZE PAGE-HEADINGS N-COPIES HOST-ADDRESS)) 
     790  (DO ((O OPTIONS (CDDR O))) 
     791      ((NULL O)) 
     792    (SELECTQ (CAR O) 
     793      (:FONT-NAME (SETQ FONT-NAME (CADR O))) 
     794      (:FACE-NAME (SETQ FACE-NAME (CADR O))) 
     795      (:FONT-SIZE (SETQ FONT-SIZE (CADR O))) 
     796      (:FONT (MULTIPLE-VALUE (FONT-NAME FACE-NAME FONT-SIZE) 
     797               (DECODE-FONT-NAME (CADR O)))) 
     798      (:PAGE-HEADINGS (SETQ PAGE-HEADINGS (CADR O))) 
     799      (:COPIES (SETQ N-COPIES (CADR O))) 
     800      (:HOST-ADDRESS (SETQ PRESS-USE-EFTP T 
     801                           HOST-ADDRESS (CADR O))) 
     802      (:FILE (SETQ HOST-ADDRESS (CADR O) 
     803                   PRESS-USE-EFTP NIL)) 
     804      (:SPOOL (SETQ HOST-ADDRESS (FORMAT NIL "MC: .DOVR.; ~A >" USER-ID) 
     805                    PRESS-USE-EFTP NIL)) 
     806      (:EFTP (SETQ HOST-ADDRESS DOVER-ADDRESS 
     807                   PRESS-USE-EFTP T)) 
     808      (:XGP (SETQ PRESS-INTERPRET-XGP-ESCAPE T 
     809                  PAGE-HEADINGS NIL)) 
     810      (OTHERWISE (FERROR NIL "~S is an unknown keyword" (CAR O))))) 
     811  (VALUES FONT-NAME FACE-NAME FONT-SIZE PAGE-HEADINGS N-COPIES HOST-ADDRESS)) 
     812 
     813(DEFUN DECODE-FONT-NAME (STRING &AUX IDX1 IDX2 (IBASE 10.)) 
     814  (DECLARE (RETURN-LIST FAMILY FACE SIZE)) 
     815  (OR (SETQ IDX1 (STRING-REVERSE-SEARCH-SET '(#/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9) 
     816                                            STRING)) 
     817      (FERROR NIL "No point size in ~A" STRING)) 
     818  (SETQ IDX2 (1+ (STRING-REVERSE-SEARCH-NOT-SET '(#/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9) 
     819                                                STRING IDX1))) 
     820  (VALUES (SUBSTRING STRING 0 IDX2) 
     821          (SUBSTRING STRING (1+ IDX1)) 
     822          (READ-FROM-STRING (SUBSTRING STRING IDX2 (1+ IDX1))))) 
     823 
     824;;; XGP support 
     825(DEFUN PRINT-XGP-FILE (FILE-NAME &REST OPTIONS) 
     826  (WITH-OPEN-FILE (STREAM FILE-NAME '(:READ :RAW :SUPER-IMAGE)) 
     827    (LEXPR-FUNCALL #'PRINT-FROM-STREAM 
     828                   (LET-CLOSED ((FILE-STREAM STREAM)) 
     829                     #'XGP-FILE-STREAM) 
     830                   (FUNCALL STREAM ':TRUENAME) ':XGP T OPTIONS))) 
     831 
     832(DEFVAR XGP-STREAM-RAW-P NIL) 
     833 
     834;;; This extra level of stream is necessary, since sometimes we want character set conversion, 
     835;;; as when reading text, and other times not, as when reading arguments. 
     836(DEFUN XGP-FILE-STREAM (OP &REST ARGS) 
     837  (DECLARE (SPECIAL FILE-STREAM)) 
     838  (SELECTQ OP 
     839    (:WHICH-OPERATIONS '(:TYI :TRUENAME :CREATION-DATE)) 
     840    (:TYI 
     841     (IF XGP-STREAM-RAW-P (FUNCALL FILE-STREAM ':TYI) 
     842         (DO ((CH)) (NIL) 
     843           (SETQ CH (FUNCALL FILE-STREAM ':TYI)) 
     844           (SELECTQ CH 
     845             (11 (RETURN #\TAB)) 
     846             (12 ) 
     847             (14 (RETURN #\FF)) 
     848             (15 (RETURN #\CR)) 
     849             (OTHERWISE (RETURN CH)))))) 
     850    (:LINE-IN (STREAM-DEFAULT-HANDLER #'XGP-FILE-STREAM OP (CAR ARGS) (CDR ARGS))) 
     851    (OTHERWISE (LEXPR-FUNCALL FILE-STREAM OP ARGS)))) 
     852 
     853(DEFCONST XGP-DOTS-PER-INCH 200.) 
     854 
     855(DEFMACRO XGP-TO-MICAS (X) 
     856  `(// (* ,X 2540.) XGP-DOTS-PER-INCH)) 
     857 
     858(DEFUN PRESS-XGP-HEADER-PAGE (INPUT-STREAM &AUX LEFT-MARGIN TOP-MARGIN BOTTOM-MARGIN) 
     859  (SETQ LEFT-MARGIN 2540.                       ;Closer to the xgp's values 
     860        TOP-MARGIN (// (* 2540. 2) 3) 
     861        BOTTOM-MARGIN TOP-MARGIN)                       
     862  (DO ((CH)) (NIL) 
     863    (SELECTQ (SETQ CH (FUNCALL INPUT-STREAM ':TYI)) 
     864      (#\FORM (RETURN NIL)) 
     865      (#\CR) 
     866      (#/; 
     867       (LET* ((LINE (FUNCALL INPUT-STREAM ':LINE-IN)) 
     868              (IDX (STRING-SEARCH-CHAR #\SP LINE)) 
     869              (IBASE 10.)) 
     870         (SELECTOR (SUBSTRING LINE 0 (PROG1 IDX (AND IDX (INCF IDX)))) STRING-EQUAL 
     871;          ("autcut") 
     872           ("botmar" 
     873            (SETQ BOTTOM-MARGIN (XGP-TO-MICAS (READ-FROM-STRING LINE NIL IDX)))) 
     874;          ("delete") 
     875           ("dfont" 
     876            (SETQ PRESS-XGP-FONT-LIST 
     877                  (LOOP FOR I = IDX THEN (1+ J) 
     878                        FOR J = (STRING-SEARCH-CHAR #/, LINE I) 
     879                        COLLECT (MULTIPLE-VALUE-BIND (FAMILY FACE SIZE) 
     880                                    (DECODE-FONT-NAME (SUBSTRING LINE I J)) 
     881                                  (PRESS-DEFINE-FONT FAMILY FACE SIZE 0)) 
     882                        WHILE J))) 
     883           ("ffcut") 
     884           ("lftmar" 
     885            (SETQ LEFT-MARGIN (XGP-TO-MICAS (READ-FROM-STRING LINE NIL IDX)))) 
     886;          ("list") 
     887           ("lsp" 
     888            (SETQ PRESS-INTERLINE-SPACING (XGP-TO-MICAS (READ-FROM-STRING LINE NIL IDX)))) 
     889           ("rgtmar") 
     890           ("skip") 
     891           ("squish") 
     892           ("topmar" 
     893            (SETQ TOP-MARGIN (XGP-TO-MICAS (READ-FROM-STRING LINE NIL IDX)))) 
     894           ("vsp") 
     895           (OTHERWISE (FERROR NIL "Unknown line ~A in XGP preamble" LINE))))) 
     896      (OTHERWISE 
     897       (FERROR NIL "Unknown character in XGP preamble ~C" CH)))) 
     898  (SETQ DOVER-X0 LEFT-MARGIN 
     899        DOVER-Y1 (- (* 11. 2540.) TOP-MARGIN BOTTOM-MARGIN PRESS-INTERLINE-SPACING) 
     900        DOVER-Y2 BOTTOM-MARGIN)) 
     901 
     902(DEFUN PRESS-XGP-ESCAPE (INPUT-STREAM &AUX (XGP-STREAM-RAW-P T) CH) 
     903  (SELECTQ (SETQ CH (FUNCALL INPUT-STREAM ':TYI)) 
     904    (1 (PRESS-XGP-ESCAPE-1 INPUT-STREAM)) 
     905    (2 (PRESS-XGP-ESCAPE-2 INPUT-STREAM)) 
     906    (3 (PRESS-XGP-ESCAPE-3 INPUT-STREAM)) 
     907    (4 (PRESS-XGP-ESCAPE-4 INPUT-STREAM)) 
     908    (OTHERWISE (PRESS-CHAR CH)))) 
     909 
     910(DEFUN PRESS-XGP-ESCAPE-1 (INPUT-STREAM &AUX CH) 
     911  (SETQ CH (FUNCALL INPUT-STREAM ':TYI)) 
     912  (IF (< CH 20) 
     913      (PRESS-SELECT-FONT (NTH CH PRESS-XGP-FONT-LIST)) 
     914      (SELECTQ CH 
     915        (40 (PRESS-XGP-SET-COLUMN INPUT-STREAM)) 
     916        (41 (PRESS-XGP-UNDERSCORE INPUT-STREAM)) 
     917        (42 (PRESS-XGP-LINE-SPACE INPUT-STREAM)) 
     918        (43 (PRESS-XGP-BASELINE-ADJUST INPUT-STREAM)) 
     919        (44 (PRESS-XGP-PRINT-PAGE-NUMBER INPUT-STREAM)) 
     920        (45 (PRESS-XGP-SPECIFY-HEADING INPUT-STREAM)) 
     921        (46 (PRESS-XGP-START-UNDERSCORE INPUT-STREAM)) 
     922        (47 (PRESS-XGP-END-UNDERSCORE INPUT-STREAM)) 
     923        (50 (PRESS-XGP-SET-INTERCHAR-SPACING INPUT-STREAM)) 
     924        (51 (PRESS-XGP-END-SPECIFIED-WIDTH-UNDERSCORE INPUT-STREAM)) 
     925        (52 (PRESS-XGP-RELATIVE-BASELINE-ADJUST INPUT-STREAM)) 
     926        (53 (PRESS-XGP-RELATIVE-UNDERSCORE INPUT-STREAM)) 
     927        (OTHERWISE (FERROR NIL "Unknown XGP escape ~O" CH))))) 
     928 
     929;;; Sign extended version of above 
     930(DEFUN PRESS-XGP-ONE-BYTE-ARG (INPUT-STREAM) 
     931  (LET ((CH (FUNCALL INPUT-STREAM ':TYI))) 
     932    (IF (BIT-TEST 100 CH) (- 200 CH) CH))) 
     933 
     934(DEFUN PRESS-XGP-TWO-BYTE-ARG (INPUT-STREAM) 
     935  (DPB (FUNCALL INPUT-STREAM ':TYI) 0707 (FUNCALL INPUT-STREAM ':TYI))) 
     936 
     937(DEFUN PRESS-XGP-THREE-BYTE-ARG (INPUT-STREAM) 
     938  (DPB (FUNCALL INPUT-STREAM ':TYI) 1607 
     939       (DPB (FUNCALL INPUT-STREAM ':TYI) 0707 (FUNCALL INPUT-STREAM ':TYI)))) 
     940 
     941(DEFUN PRESS-XGP-SET-COLUMN (INPUT-STREAM) 
     942  (PRESS-SET-CURSOR (XGP-TO-MICAS (PRESS-XGP-TWO-BYTE-ARG INPUT-STREAM)) PRESS-Y)) 
     943 
     944(DEFUN PRESS-XGP-UNDERSCORE (INPUT-STREAM) 
     945  (PRESS-XGP-DO-UNDERSCORE (- PRESS-Y (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM))) 
     946                           PRESS-X (PRESS-XGP-TWO-BYTE-ARG INPUT-STREAM) 2.)) 
     947 
     948(DEFUN PRESS-XGP-LINE-SPACE (INPUT-STREAM) 
     949  (SETQ PRESS-INTERCHAR-SPACING NIL) 
     950  (PRESS-SET-CURSOR PRESS-X (- PRESS-Y (XGP-TO-MICAS (FUNCALL INPUT-STREAM ':TYI))))) 
     951 
     952(DEFUN PRESS-XGP-BASELINE-ADJUST (INPUT-STREAM) 
     953  (SETQ PRESS-INTERCHAR-SPACING NIL) 
     954  (PRESS-SET-CURSOR 
     955    (SETQ PRESS-BASELINE-Y (+ PRESS-Y (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM)))) 
     956    PRESS-X)) 
     957 
     958(DEFUN PRESS-XGP-PRINT-PAGE-NUMBER (IGNORE) 
     959  (PRESS-STRING (FORMAT NIL "~D" PRESS-PAGE-NUMBER))) 
     960 
     961(DEFUN PRESS-XGP-SPECIFY-HEADING (INPUT-STREAM) 
     962  (LET* ((LENGTH (FUNCALL INPUT-STREAM ':TYI)) 
     963         (STRING (MAKE-ARRAY LENGTH ':TYPE 'ART-STRING))) 
     964    (LOOP FOR I FROM 0 BELOW LENGTH 
     965          DO (ASET (FUNCALL INPUT-STREAM ':TYI) STRING I)) 
     966    (SETQ PRESS-END-PAGE-HOOK (LET-CLOSED ((STRING STRING)) 
     967                                #'(LAMBDA () 
     968                                    (FORMAT T "~D " PRESS-PAGE-NUMBER) 
     969                                    (WITH-INPUT-FROM-STRING (INPUT-STREAM STRING) 
     970                                      (DO ((CH)) 
     971                                          ((NULL (SETQ CH (FUNCALL INPUT-STREAM ':TYI)))) 
     972                                        (IF (AND PRESS-INTERPRET-XGP-ESCAPE (= CH 177)) 
     973                                            (PRESS-XGP-ESCAPE INPUT-STREAM) 
     974                                            (PRESS-CHAR CH))))))))) 
     975 
     976(DEFUN PRESS-XGP-START-UNDERSCORE (IGNORE) 
     977  (SETQ PRESS-XGP-UNDERLINE-START-X PRESS-X)) 
     978 
     979(DEFUN PRESS-XGP-END-UNDERSCORE (INPUT-STREAM) 
     980  (PRESS-XGP-DO-UNDERSCORE (- PRESS-BASELINE-Y 
     981                              (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM))) 
     982                           PRESS-XGP-UNDERLINE-START-X 
     983                           PRESS-X 2.)) 
     984 
     985(DEFUN PRESS-XGP-SET-INTERCHAR-SPACING (INPUT-STREAM) 
     986  (SETQ PRESS-INTERCHAR-SPACING (XGP-TO-MICAS (FUNCALL INPUT-STREAM ':TYI)))) 
     987 
     988(DEFUN PRESS-XGP-END-SPECIFIED-WIDTH-UNDERSCORE (INPUT-STREAM) 
     989  (LET ((WIDTH (FUNCALL INPUT-STREAM ':TYI))) 
     990    (PRESS-XGP-DO-UNDERSCORE (- PRESS-BASELINE-Y 
     991                                (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM))) 
     992                             PRESS-XGP-UNDERLINE-START-X 
     993                             PRESS-X WIDTH))) 
     994 
     995(DEFUN PRESS-XGP-RELATIVE-BASELINE-ADJUST (INPUT-STREAM) 
     996  (PRESS-SET-CURSOR 
     997    (SETQ PRESS-BASELINE-Y (+ PRESS-BASELINE-Y 
     998                              (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM)))) 
     999    PRESS-X)) 
     1000 
     1001(DEFUN PRESS-XGP-RELATIVE-UNDERSCORE (INPUT-STREAM) 
     1002  (PRESS-XGP-DO-UNDERSCORE (- PRESS-BASELINE-Y 
     1003                              (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM))) 
     1004                           PRESS-X (PRESS-XGP-TWO-BYTE-ARG INPUT-STREAM) 2.)) 
     1005 
     1006(DEFUN PRESS-XGP-DO-UNDERSCORE (TOP-Y X-START X-END THICKNESS &AUX (OX PRESS-X) (OY PRESS-Y)) 
     1007  (PRESS-SET-CURSOR X-START (- TOP-Y THICKNESS)) 
     1008  (PRESS-ENTITY-BYTE 376)       ;Show-rectangle 
     1009  (PRESS-ENTITY-WORD (- X-END X-START))         ;Width 
     1010  (PRESS-ENTITY-WORD (XGP-TO-MICAS THICKNESS))  ;Thickness 
     1011  (PRESS-SET-CURSOR OX OY)) 
     1012 
     1013(DEFUN PRESS-XGP-ESCAPE-2 (INPUT-STREAM) 
     1014  (PRESS-SET-CURSOR (+ PRESS-X (XGP-TO-MICAS (PRESS-XGP-ONE-BYTE-ARG INPUT-STREAM))) 
     1015                    PRESS-Y)) 
     1016 
     1017(DEFUN PRESS-XGP-ESCAPE-3 (IGNORE) 
     1018  (FERROR NIL "XGP escape 3 not implemented")) 
     1019 
     1020(DEFUN PRESS-XGP-ESCAPE-4 (IGNORE) 
     1021  (FERROR NIL "XGP escape 4 not implemented")) 
    7201022 
    7211023;;;;Font sampling 
     
    7241026; rotation is optional and defaults to 0 
    7251027(DEFUN SAMPLE-FONTS (FONT-LIST &OPTIONAL (UPPER-HALF NIL) 
    726                                          (SEND-TO-MOONS-ALTO-P NIL) 
    7271028                                         (HOST-ADDRESS DOVER-ADDRESS) 
    728                                &AUX (PRESS-USE-EFTP PRESS-USE-EFTP) FOO CH) 
    729   (AND SEND-TO-MOONS-ALTO-P (SETQ PRESS-USE-EFTP T)) 
    730   (OR SEND-TO-MOONS-ALTO-P (STRINGP HOST-ADDRESS) (PRINT-DOVER-STATUS)) 
    731   (PRESS-START-FILE (IF SEND-TO-MOONS-ALTO-P 926-ALTO-ADDRESS HOST-ADDRESS)) 
     1029                               &AUX FOO CH) 
     1030 (BIND-PRESS-VARIABLES 
     1031  (PRESS-START-FILE HOST-ADDRESS) 
    7321032  (LET ((LABEL-FONT (PRESS-DEFINE-FONT "TIMESROMAN" "" 10. 0)) THIS-FONT NOT-IN-FONTS-WIDTHS) 
    7331033    (DO ((L FONT-LIST (CDR L)) 
     
    7391039      (COND ((= I 16.)                          ;Got to make a new file 
    7401040             (PRESS-END-FILE "Font samples" "") 
    741              (RETURN (SAMPLE-FONTS L UPPER-HALF SEND-TO-MOONS-ALTO-P)))) 
     1041             (RETURN (SAMPLE-FONTS L UPPER-HALF)))) 
    7421042      (PRESS-START-PAGE) 
    7431043      (MULTIPLE-VALUE (THIS-FONT NOT-IN-FONTS-WIDTHS) 
     
    7751075      (PRESS-CHAR-SEQ #/! #/?) 
    7761076      (PRESS-CHAR-SEQ #/[ #/_) 
    777       (PRESS-CHAR-SEQ #/{ #/‡ #\CR) 
     1077      (PRESS-CHAR-SEQ #/{ #/ #\CR) 
    7781078      (PRESS-CHAR-SEQ #/ #/) 
    7791079      (PRESS-SET-CURSOR 0 4150.) 
     
    7941094      (PRESS-SET-CURSOR 8750. PRESS-Y) 
    7951095      (PRESS-STRING "             (T (CONS (CAR X) (APPEND (CDR X) Y)))))") 
    796       (PRESS-END-PAGE)))) 
     1096      (PRESS-END-PAGE))))) 
    7971097 
    7981098(DEFUN PRESS-CHAR-SEQ (FIRST LAST &OPTIONAL EXTRA) 
     
    8601160 
    8611161  (TEMPLATE || 64.) )) 
     1162 
     1163;; Read in all fonts from FONTS;DOVER FONTS 
     1164(DEFUN COMPUTE-DOVER-FONTS (&AUX NAME FACE POINT ROT TEM ANSWER (IBASE 10.)) 
     1165  (WITH-OPEN-FILE (I "AI: FONTS; DOVER FONTS") 
     1166    (DO ((LINE) (EOF)) (NIL) 
     1167      (MULTIPLE-VALUE (LINE EOF) 
     1168        (FUNCALL I ':LINE-IN)) 
     1169      (AND EOF 
     1170           (OR (NULL LINE) (EQUAL LINE "")) 
     1171           (RETURN (NREVERSE ANSWER))) 
     1172      (SETQ TEM (STRING-SEARCH-CHAR #/, LINE) 
     1173            NAME (INTERN (SUBSTRING LINE 7 TEM) "PRESS") 
     1174            TEM (+ TEM 2) 
     1175            FACE (COND ((STRING-EQUAL LINE "MR" TEM 0 (+ TEM 2) 2) '||) 
     1176                       ((STRING-EQUAL LINE "MI" TEM 0 (+ TEM 2) 2) 'I) 
     1177                       ((STRING-EQUAL LINE "BR" TEM 0 (+ TEM 2) 2) 'B) 
     1178                       ((STRING-EQUAL LINE "BI" TEM 0 (+ TEM 2) 2) 'BI) 
     1179                       (T (FERROR NIL "Parsing error in fonts file."))) 
     1180            TEM (1+ (STRING-SEARCH-CHAR #/( LINE TEM)) 
     1181            POINT (READ-FROM-STRING LINE 'SI:NO-EOF-OPTION TEM) 
     1182            TEM (+ (STRING-SEARCH-CHAR #/: LINE TEM) 2) 
     1183            ROT (READ-FROM-STRING LINE 'SI:NO-EOF-OPTION TEM)) 
     1184      (PUSH (LIST NAME FACE POINT ROT) ANSWER)))) 
     1185 
    8621186 
    8631187(COMMENT ;hacks 
     
    8871211  (PRESS-END-FILE "Lines" "")) 
    8881212);comment 
     1213 
     1214;;; ZWEI interface 
     1215;;; should have a way of setting this stuff 
     1216(DEFVAR DIRED-PRINT-OPTIONS NIL) 
     1217 
     1218(DEFUN (:DOVER :DIRED-PRINT-FUNCTION) (PATHNAME TYPE) 
     1219  (SELECTQ TYPE 
     1220    (:SUDS-PLOT 
     1221     (AND (NOT (FBOUNDP ':DPLT-PRINT-FILE)) 
     1222          (LOAD "SYS: IO1; DPLT PKG >") 
     1223          (PKG-LOAD 'DPLT '(:NOCONFIRM))) 
     1224     (:DPLT-PRINT-FILE PATHNAME) 
     1225     T) 
     1226    (:XGP 
     1227     (LEXPR-FUNCALL #'PRINT-XGP-FILE PATHNAME DIRED-PRINT-OPTIONS)) 
     1228    (:TEXT (LEXPR-FUNCALL #'PRINT-FILE PATHNAME DIRED-PRINT-OPTIONS)) 
     1229    (:PRESS (LEXPR-FUNCALL #'PRINT-PRESS-FILE PATHNAME DIRED-PRINT-OPTIONS)) 
     1230    (OTHERWISE (FORMAT NIL "I don't know how to print files of type ~A" TYPE)))) 
     1231 
  • 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 
     
    7374  (OR (BOUNDP 'PROGRAMMER-STREAM) 
    7475      (SETQ PROGRAMMER-STREAM (SI:MAKE-SERIAL-STREAM 
    75                                 ':PARITY NIL ':NUMBER-OF-DATA-BITS 8 ':BAUD 300.))) 
     76                                ':PARITY NIL 
     77                                ':NUMBER-OF-DATA-BITS 8 
     78                                ':BAUD #+MIT 300. #+SYM 1200.))) 
    7679  (FUNCALL PROGRAMMER-STREAM ':CLEAR-INPUT) 
    7780  (FUNCALL PROGRAMMER-STREAM ':TYO 33)          ;This resets the programmer 
     
    106109(DEFUN PROGRAMMER-READ-RAM (&OPTIONAL (ARRAY (MAKE-ARRAY NIL 'ART-8B 
    107110                                                         (1+ PROGRAMMER-DEVICE-WORD-LIMIT)))) 
     111  (PROGRAMMER-RESET) 
    108112  (MULTIPLE-VALUE-BIND (IGNORE FAILURE) 
    109113      (PROGRAMMER-COMMAND "83A" NIL) 
     
    111115         (FERROR NIL "Cannot set transfer format")) 
    112116    (PROGRAMMER-COMMAND "O" 'NONE) 
    113     (DO ((BYTE-COUNT) (PROGRAMMER-CHECKSUM 0 0) (ADR 0) (CS) (RECORD-TYPE)) 
     117    (DO ((BYTE-COUNT) (PROGRAMMER-CHECKSUM 0 0) (ADR 0) (CS) (RECORD-TYPE) 
     118         (ARRAY-LEN (ARRAY-LENGTH ARRAY))) 
    114119        (()) 
    115120      ;Start character is a colon 
     
    120125      (SELECTQ RECORD-TYPE 
    121126        (00                                     ;Data record 
     127         (COND (( 
     128 ADR ARRAY-LEN) 
     129                ;; With the new software, it seems that the programmer can overrun the array 
     130                (FORMAT T "~&Programmer sending too much data, resetting.") 
     131                (PROGRAMMER-RESET) 
     132                (RETURN NIL))) 
    122133         (DOTIMES (I BYTE-COUNT) 
    123            (ASET (HEX-READ-BYTE) ARRAY (+ ADR I))) 
     134           (LET ((BYTE (HEX-READ-BYTE))) 
     135             (AND  (< (+ ADR I) ARRAY-LEN) 
     136                   (ASET BYTE ARRAY (+ ADR I))))) 
    124137         (SETQ CS (LOGAND (- PROGRAMMER-CHECKSUM) 377)) 
    125138         (COND (( (SETQ RECORD-TYPE (HEX-READ-BYTE)) CS) 
     
    243256     (PROGRAMMER-COMMAND "P")) 
    244257   (COND (FAIL 
    245           (FORMAT T "&~Programming failed.") 
     258          (FORMAT T "~&Programming failed.") 
    246259          (RETURN NIL))) 
    247260   (FORMAT T "~&Verifying device.") 
     
    318331    (OR FROM (DO () ((PROGRAMMER-PROGRAM-PROM (CAR PROM)))))) 
    319332  'DONE) 
     333 
  • 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. 
     
    112112;Dump the file property list 
    113113;as a bunch of defprops to be evaluated at load time. 
    114 (defun dump-file-property-list (file-group-symbol plist) 
     114(defun dump-file-property-list (generic-pathname plist) 
     115  (dump-form `(set-generic-pathname-property-list 
     116                ;; Cannot fasd instances yet. 
     117                ,(funcall generic-pathname ':string-for-printing) 
     118                ,plist))) 
     119 
     120(defun set-generic-pathname-property-list (generic-pathname-string plist &aux pathname) 
     121  (setq pathname (funcall (fs:merge-pathname-defaults generic-pathname-string) 
     122                          ':generic-pathname)) 
    115123  (do ((l plist (cddr l))) ((null l)) 
    116     (dump-form `(defprop ,file-group-symbol (cadr l) (car l))))) 
     124    (funcall pathname ':putprop (cadr l) (car l)))) 
    117125 
    118126;Dump a form to be evaluated at load time. 
  • trunk/lisp/lmio1/relld.lisp

    r253 r288  
    421421               (set form (%p-contents-offset org (setq i (1+ i))))) 
    422422              ((= type 2) 
    423                (prog (tem si:fdefine-file-symbol) 
     423               (prog (tem si:fdefine-file-pathname) 
    424424                     (setq tem (%p-contents-offset org (setq i (1+ i))) 
    425                            si:fdefine-file-symbol (%p-contents-offset org (setq i (1+ i)))) 
     425                           si:fdefine-file-pathname (%p-contents-offset org (setq i (1+ i)))) 
    426426                     (fset-carefully form tem)))))))) 
    427427 
  • 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 (comment ;This does not even compile! 
    287 (if-for-lispm 
    288 ;Read in an AC file as a Lisp machine font. 
    289 (defun load-font (filename &optional family-name face-name point-size) 
    290  (unwind-protect 
    291   (let ((widths-file (open filename '(read fixnum))) 
    292         (code-alist nil) 
    293         (segment-data nil) 
    294         family-code tem segment 
    295         (wd 0)) 
    296     (setq wd (next-word)) 
    297     ;; Read IXN entries (type 1) 
    298     (do () ((not (= (lsh wd -12.) 1))) 
    299       (let ((code (next-word)) 
    300             (name (bcpl-string 20.))) 
    301         (push (cons code name) code-alist)) 
    302       (setq wd (next-word))) 
    303     ;; Find out the code number for the font family to be used, 
    304     ;; either the specified one or the only one. 
    305     (cond (family-name (setq family-code (name-to-code family-name))) 
    306           ((cdr code-alist) 
    307            (ferror nil "Font dictionary ~A: font family not specified" filename)) 
    308           (t (setq family-code (caar code-alist)))) 
    309     ;; Read Index Entries (type 3) for AC segments. 
    310     (do () ((not (= (lsh wd -12.) 4))) 
    311       (setq wd (next-word))             ;family,,face 
    312       (setq tem 
    313             (list (high-byte wd)                        ;Family code number. 
    314                   (decode-face (low-byte wd))           ;Face name 
    315                   (progn (setq wd (next-word))          ;bc,,ec 
    316                          (high-byte wd))                ;First code 
    317                   (low-byte wd)                         ;Last code 
    318                   (next-word)                           ;Size 
    319                   (next-word)                           ;Rotation 
    320                   (+ (lsh (next-word) 16.) (next-word)) ;Segment SA 
    321                   (+ (lsh (next-word) 16.) (next-word))));Segment Len 
    322       (next-word) (next-word)                   ;Ignore resolution values. 
    323       (and (= (car tem) family-code) (push tem segment-data)) 
    324       (setq wd (next-word))) 
    325     ;; Now should have type-0 entry (end of index) 
    326     (or (zerop (lsh wd -12.)) 
    327         (error '|Bullshit in file where type 0 IX expected| wd)) 
    328     ;; Now either there should be only one segment or the face code and size 
    329     ;; should have been specified. 
    330     (cond (point-size (dolist (seg segment-data) 
    331                         (and (eq (cadr seg) face-code) 
    332                              (= (fifth seg) point-size) 
    333                              (return (setq segment seg))))) 
    334           ((cdr segment-data) 
    335            (ferror "Font dictionary ~A: point size not specified" filename)) 
    336           ((setq segment (car segment-data)))) 
    337     (funcall widths-file ':set-pointer (seventh segment)) 
    338     (let ((bc (third segment)) 
    339           (ec (fourth segment)) 
    340           line-height) 
    341       (setq xwidths (make-array nil art-16b 200)) 
    342       (setq ywidths (make-array nil art-16b 200)) 
    343       (setq box-x-offset (make-array nil art-16b 200)) 
    344       (setq box-y-offset (make-array nil art-16b 200)) 
    345       (setq box-x-size (make-array nil art-16b 200)) 
    346       (setq box-y-size (make-array nil art-16b 200)) 
    347       ;; read in the widths info from the segment. 
    348       (do ((i bc (1+ i))) ((> i ec)) 
    349         (aset (next-word) xwidths i) 
    350         (next-word) 
    351         (aset (next-word) ywidths i) 
    352         (next-word) 
    353         (aset (next-word) box-x-offset i) 
    354         (aset (next-word) box-y-offset i) 
    355         (aset (next-word) box-x-size i) 
    356         (aset (next-word) box-y-size i)) 
    357       ;; Ignore the table of offsets to the raster info 
    358       (do ((i bc (1+ i))) ((>i ec)) 
    359         (next-word)) 
    360       (setq fontname (string-append (code-to-name family-code) 
    361                                     (format nil "~D" point-size) 
    362                                     (second segment))) 
    363       (setq fontname (intern (string-upcase fontname) "FONTS")) 
    364       (setq fd (fed:make-font-descriptor fed:fd-name fontname)) 
    365       (do ((height 0) 
    366            (baseline 0) 
    367            (i bc (1+ i))) 
    368           ((> i ec) 
    369            (setq line-height (+ height baseline)) 
    370            (setf (fed:fd-line-spacing fd) line-height) 
    371            (setf (fed:fd-blinker-height fd) line-height) 
    372            (setf (fed:fd-baseline fd) baseline)) 
    373         (cond (( (aref box-y-size i) -1) 
    374                (setq height (max height (= (aref box-x-size i) (aref box-x-offset i)))))) 
    375         (cond (( (aref box-y-size i) -1) 
    376                (setq baseline (max baseline (- (aref box-y-offset i))))))) 
    377       (do ((i bc (1+ i)) 
    378            (char-width) 
    379            (raster-height) 
    380            (raster-width) 
    381            (char-baseline) 
    382            (wd) 
    383            (cd)) 
    384           ((> i ec)) 
    385         (cond (( (aref box-y-size i) -1) 
    386                (setq char-width (aref xwidths i)) 
    387                (setq raster-width (aref box-x-size i)) 
    388                (setq raster-height (aref box-y-size i)) 
    389                (setq char-y-offset (aref box-y-offset i)) 
    390                (setq cd (fed:make-char-descriptor make-array (nil art-1b (list line-height 
    391                                                                            raster-width)))) 
    392                (setf (cd-char-width cd) char-width) 
    393                (and (= ch #\sp) (setf (fed:fd-space-width fd) char-width)) 
    394                (setf (cd-char-left-kern cd) (aref box-x-offset i)) 
    395                (aset cd fd ch) 
    396                (next-word) (next-word) 
    397                (dotimes (hpos raster-width) 
    398                  ;; Read in the next vertical scan line. 
    399                  (dotimes (vpos raster-height) 
    400                   ;; If wd is exhausted, get next word into wd 
    401                   (cond ((zerop (\ vpos 16.)) 
    402                          (setq wd (next-word)))) 
    403                   (setq tem (logand 1 (lsh wd (- (\ hpos 16.))))) 
    404                   (as-2 tem cd 
    405                         (+ vpos baseline char-y-offset) 
    406                         hpos)))))) 
    407       (setf (fed:fd-fill-pointer fd) 200) 
    408       ;; Set width of blinker and space fields from the space character. 
    409       (setf (fed:fd-blinker-width fd) (fed:fd-space-width fd)) 
    410       (fed:font-name-set-font-and-descriptor fontname fd) 
    411       fontname)) 
    412   (close widths-file)))) 
    413 );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                                 &nb