Index: /trunk/lisp/lmio1/cdrive.lisp =================================================================== --- /trunk/lisp/lmio1/cdrive.lisp (revision 252) +++ /trunk/lisp/lmio1/cdrive.lisp (revision 253) @@ -9,4 +9,6 @@ (DEFVAR MILLS-TO-STEPS NIL) + +(DECLARE (SPECIAL CTEST-BOARD-TYPE)) (DECLARE (SPECIAL MPG216-GXOFST)) @@ -629,37 +631,55 @@ (COND ((NULL MILLS-TO-STEPS) (SETQ MILLS-TO-STEPS (// 1434. (FLOAT (* 5 MPG216-GXOFST)))))) - (FORMAT T "~%Position ~S probe over 1A01-10" NAME) + (FORMAT T (SELECTQ CTEST-BOARD-TYPE + (MPG216 "~%Position ~S probe over 1A01-10") + (LG684 "~%Position ~S probe over A1-10")) + NAME) (<- SELF ':MANUAL-CONTROL) (<- SELF ':probe-up) - (FORMAT T "~%RECOMPUTE MILLS-TO-STEPS?") - (COND ((Y-OR-N-P) + (COND ((Y-OR-N-P "RECOMPUTE MILLS-TO-STEPS?") (<- self ':manual-control) - (FORMAT T "~%Now position it over 1F01-10") + (FORMAT T (SELECTQ CTEST-BOARD-TYPE + (MPG216 "~%Now position it over 1F01-10") + (LG684 "~%Now position it over A30-10"))) (<- SELF ':probe-up) (MULTIPLE-VALUE (XD YD) (<- self ':manual-control ctest-slow-speed)) (FORMAT T "~%That was ~d xsteps, ~d ysteps" XD YD) - (SETQ MILLS-TO-STEPS (// YD (FLOAT (* 5 MPG216-GXOFST)))) - (SETQ POS "1F01-10") + (SETQ MILLS-TO-STEPS (// YD (FLOAT + (SELECTQ CTEST-BOARD-TYPE + (MPG216 (* 5 MPG216-GXOFST)) + (LG684 (* 30. LG684-XDIPSP)))))) + (SETQ POS (SELECTQ CTEST-BOARD-TYPE + (MPG216 "1F01-10") + (LG684 "A30-10"))) (<- SELF ':DEFINE-POSITION-STRING-LOC POS)) - (T (SETQ POS "1A01-10") + (T (SETQ POS (SELECTQ CTEST-BOARD-TYPE + (MPG216 "1A01-10") + (LG684 "A1-10"))) (<- SELF ':DEFINE-POSITION-STRING-LOC POS))) (COND (REDO-CALIB - (FORMAT T "~%HOW MANY BOARDS?") - (SETQ NBOARDS (READ)) - (DOTIMES (C NBOARDS) - (CALIBRATE-AT-LOC (1+ C) (FORMAT NIL "~DA1-10" (1+ C)) CALIBRATOR) - (CALIBRATE-AT-LOC (1+ C) (FORMAT NIL "~DF1-10" (1+ C)) CALIBRATOR)) -; (CALIBRATE-AT-LOC NBOARDS (FORMAT NIL "~DA15-10" NBOARDS) CALIBRATOR) -; (CALIBRATE-AT-LOC NBOARDS (FORMAT NIL "~DF11-10" NBOARDS) CALIBRATOR) - (CALIBRATE-AT-LOC NBOARDS (FORMAT NIL "~DA30-10" NBOARDS) CALIBRATOR) - (CALIBRATE-AT-LOC NBOARDS (FORMAT NIL "~DF25-10" NBOARDS) CALIBRATOR))) + (SELECTQ CTEST-BOARD-TYPE + (MPG216 + (FORMAT T "~%HOW MANY BOARDS?") + (SETQ NBOARDS (READ)) + (DOTIMES (C NBOARDS) + (CALIBRATE-AT-LOC (1+ C) (FORMAT NIL "~DA1-10" (1+ C)) CALIBRATOR) + (CALIBRATE-AT-LOC (1+ C) (FORMAT NIL "~DF1-10" (1+ C)) CALIBRATOR)) + (CALIBRATE-AT-LOC NBOARDS (FORMAT NIL "~DA30-10" NBOARDS) CALIBRATOR) + (CALIBRATE-AT-LOC NBOARDS (FORMAT NIL "~DF25-10" NBOARDS) CALIBRATOR)) + (LG684 + (CALIBRATE-AT-LOC 1 "F1-10" CALIBRATOR) + (CALIBRATE-AT-LOC 1 "F30-10" CALIBRATOR))))) (PRINT-CALIBRATION))) (DEFMETHOD (PROBE-CLASS :RECALIBRATE-BOARD) (BOARD-NUM - &OPTIONAL AUTO-FLAG (LOCS '("A1-10" "F1-10" "A29-10" "F26-10"))) + &OPTIONAL AUTO-FLAG (LOCS (SELECTQ CTEST-BOARD-TYPE + (MPG216 '("A1-10" "F1-10" "A29-10" "F26-10")) + (LG684 '("A1-10" "A1-30" "F1-10" "F1-30"))))) (<- CALIBRATOR ':FLUSH-CALIBRATION-FOR-BOARD BOARD-NUM) (DOLIST (L LOCS) (CALIBRATE-AT-LOC BOARD-NUM - (STRING-APPEND (FORMAT NIL "~D" BOARD-NUM) L) + (SELECTQ CTEST-BOARD-TYPE + (MPG216 (STRING-APPEND (FORMAT NIL "~D" BOARD-NUM) L)) + (LG684 L)) CALIBRATOR AUTO-FLAG) @@ -758,5 +778,6 @@ ((EQ CH #\RUBOUT) (RETURN T))) - (COND ((BIT-TEST BD 1) + (COND ((NULL BD) (GO L)) + ((BIT-TEST BD 1) (<- SELF (COND (DOWN-P ':PROBE-UP) (T ':PROBE-DOWN)))) @@ -772,12 +793,28 @@ ) -(DEFUN MOVE-CHAR-TYI-OR-MOUSE-BUTTON NIL - TV:(PROG (NEW-BUTTONS CHANGED-BUTTONS) +(DEFUN MOVE-CHAR-OR-TYI-OR-MOUSE-BUTTON (&OPTIONAL (TV:STREAM STANDARD-INPUT)) + TV:(PROG (NEW-BUTTONS CHANGED-BUTTONS IO-BUFFER) + (SETQ IO-BUFFER (FUNCALL STREAM ':IO-BUFFER)) L (PROCESS-ALLOW-SCHEDULE) (PROCESS-WAIT "mouse" - #'(LAMBDA (&AUX (NH1 )) - (OR () + #'(LAMBDA (IO-BUFFER) + (OR (NULL (IO-BUFFER-EMPTY-P IO-BUFFER)) + (IF (EQ IO-BUFFER (KBD-GET-IO-BUFFER)) + (NULL (IO-BUFFER-EMPTY-P KBD-IO-BUFFER))) ( MOUSE-LAST-BUTTONS - (LDB 1403 (%UNIBUS-READ MOUSE-REG1)))))) + (LDB 1403 (%UNIBUS-READ MOUSE-REG1))))) + IO-BUFFER) + (IF (FUNCALL STREAM ':LISTEN) + (LET ((CH (FUNCALL STREAM ':TYI))) + (MULTIPLE-VALUE-BIND (DX DY) (USER:KEYSTROKE-MOVE-DELTA CH) + (IF (NULL DX) + (RETURN CH) + (RETURN NIL NIL DX DY))))) + (SETQ NEW-BUTTONS (MOUSE-BUTTONS) + CHANGED-BUTTONS (LOGXOR NEW-BUTTONS MOUSE-LAST-BUTTONS) + MOUSE-LAST-BUTTONS NEW-BUTTONS) + (IF (ZEROP (LOGAND NEW-BUTTONS CHANGED-BUTTONS)) + (GO L) + (RETURN NIL (LOGAND NEW-BUTTONS CHANGED-BUTTONS)))) ) Index: /trunk/lisp/lmio1/dplt.pkg =================================================================== --- /trunk/lisp/lmio1/dplt.pkg (revision 253) +++ /trunk/lisp/lmio1/dplt.pkg (revision 253) @@ -0,0 +1,8 @@ +; -*- LISP -*- +; Package definition for the SUDS plotting program + +(PACKAGE-DECLARE DPLT GLOBAL 1000. + (("AI:LMIO1;DPLT QFASL"))) + +(OR (FBOUNDP 'PRESS:PRESS-START-FILE) (LOAD "AI:LMIO1;PRESS QFASL")) +(OR (BOUNDP 'PRESS:FONT-WIDTH-DATA) (PRESS:LOAD-FONT-WIDTHS)) Index: /trunk/lisp/lmio1/rfontw.lisp =================================================================== --- /trunk/lisp/lmio1/rfontw.lisp (revision 252) +++ /trunk/lisp/lmio1/rfontw.lisp (revision 253) @@ -178,5 +178,5 @@ (cond ((not (zerop (boole 1 100000 m))) (setq xwidths (next-word))) - (t (setq xwidths (*array nil 'fixnum 200)) + (t (setq xwidths (*array nil 'fixnum 400)) (fillarray xwidths '(-1)) ;Chars not in bc..ec have -1 (do ((j (caddr seg) (1+ j)) @@ -189,5 +189,5 @@ (cond ((not (zerop (boole 1 40000 m))) (setq ywidths (next-word))) - (t (setq ywidths (*array nil 'fixnum 200)) + (t (setq ywidths (*array nil 'fixnum 400)) (fillarray xwidths '(-1)) ;Chars not in bc..ec have -1 (do ((j (caddr seg) (1+ j)) @@ -236,5 +236,5 @@ (cond ((not (zerop (caddr dat))) ;Already got data in micas (cond ((numberp xwidths) ;Fixed-width font - (setq tem (*array nil 'fixnum 200)) + (setq tem (*array nil 'fixnum 400)) (fillarray tem (list xwidths)) (setq xwidths tem))) @@ -242,5 +242,5 @@ ((numberp xwidths) ;Fixed-width font (setq tem (// (* xwidths 2540. point-size) 72000.)) - (setq xwidths (*array nil 'fixnum 200)) + (setq xwidths (*array nil 'fixnum 400)) (fillarray xwidths (list tem)) xwidths) Index: /trunk/lisp/lmio1/votrax.lisp =================================================================== --- /trunk/lisp/lmio1/votrax.lisp (revision 252) +++ /trunk/lisp/lmio1/votrax.lisp (revision 253) @@ -1,4 +1,5 @@ ;;;-*-LISP-*- +(comment (DECLARE (SPECIAL DL11-RCV-CSR DL11-RCV-DAT DL11-XMT-CSR DL11-XMT-DAT)) (SETQ DL11-RCV-CSR 775630) @@ -20,5 +21,10 @@ (( I LEN)) - (DL11-TYO (AR-1 STR I)))) + (DL11-TYO (AR-1 STR I)))) ) + +(declare (special votrax-stream)) + +(setq votrax-stream (si:make-serial-stream)) + (DECLARE (SPECIAL PHONEME-ALIST LAST-UTTERANCE)) @@ -68,10 +74,10 @@ (INT 300) (PH)) - ((NULL LIST) (DL11-TYO -1) T) + ((NULL LIST) (funcall votrax-stream ':TYO -1) T) (SETQ PH (CAR LIST)) (COND ((NUMBERP PH) (SETQ INT (- 400 (* PH 100)))) (T - (DL11-TYO (+ INT (CDR (ASSQ PH PHONEME-ALIST)))))))) + (funcall votrax-stream ':tyo (+ INT (CDR (ASSQ PH PHONEME-ALIST)))))))) (DEFUN SPEAK (&OPTIONAL (X LAST-UTTERANCE)) @@ -120,6 +126,6 @@ (DEFUN SPEAK-RAN (N) (DOTIMES (I N) - (DL11-TYO (RANDOM 400))) - (DL11-TYO -1)) + (funcall votrax-stream ':TYO (RANDOM 400))) + (funcall votrax-stream ':TYO -1)) (DEFUN OPERATOR () Index: /trunk/lisp/lmio1/chatst.lisp =================================================================== --- /trunk/lisp/lmio1/chatst.lisp (revision 252) +++ /trunk/lisp/lmio1/chatst.lisp (revision 253) @@ -174,11 +174,11 @@ (DO () ((LDB-TEST %%CHAOS-CSR-RECEIVE-DONE (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST)))) - (PROCESS-SLEEP 30.)) ;Give it time to arrive + (PROCESS-SLEEP 10.)) ;Give it time to arrive (SETQ CSR (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST)) (SETQ ME (%UNIBUS-READ MY-NUMBER-REGISTER-TEST)) + (IF (NOT (ZEROP (LDB-TEST %%CHAOS-CSR-TRANSMIT-ABORT CSR))) + (FORMAT t "~%Transmit aborted, then~%")) (COND ((NOT (LDB-TEST %%CHAOS-CSR-RECEIVE-DONE CSR)) (SETQ LOSE T) (PRINT 'NO-RECEIVE)) - ((LDB-TEST %%CHAOS-CSR-TRANSMIT-ABORT CSR) - (SETQ LOSE T) (PRINT 'TRANSMIT-ABORT)) (T (AND (LDB-TEST %%CHAOS-CSR-CRC-ERROR CSR) (PROGN (SETQ LOSE T) Index: /trunk/lisp/lmio1/hacks.lisp =================================================================== --- /trunk/lisp/lmio1/hacks.lisp (revision 252) +++ /trunk/lisp/lmio1/hacks.lisp (revision 253) @@ -1,3 +1,3 @@ -;-*-LISP-*- +;-*-MODE: LISP; PACKAGE: USER; BASE: 8-*- ; ** (c) Copyright 1980 Massachusetts Institute of Technology ** Index: /trunk/lisp/lmio1/draw.lisp =================================================================== --- /trunk/lisp/lmio1/draw.lisp (revision 252) +++ /trunk/lisp/lmio1/draw.lisp (revision 253) @@ -1,3 +1,6 @@ -;USER FUNCTIONS: -*-lisp-*- +; -*-lisp-*- +; ** (c) Copyright 1980 Massachusetts Institute of Technology ** + +;USER FUNCTIONS: ; (DRAW-LINE initial-X initial-Y final-X final-Y &OPTIONAL mode) ; (DRAW-CIRCLE center-X center-Y radius &OPTIONAL mode) Index: /trunk/lisp/lmio1/xgp.lisp =================================================================== --- /trunk/lisp/lmio1/xgp.lisp (revision 252) +++ /trunk/lisp/lmio1/xgp.lisp (revision 253) @@ -61,4 +61,5 @@ (let ((inhibit-scheduling-flag t) (hcarray (allocate-resource 'xgp-hardcopy-bit-array))) + (tv:who-line-update) (copy-array-contents array hcarray) (process-run-function "XGP Hardcopy" Index: /trunk/lisp/lmio1/escape.lisp =================================================================== --- /trunk/lisp/lmio1/escape.lisp (revision 252) +++ /trunk/lisp/lmio1/escape.lisp (revision 253) @@ -138,5 +138,6 @@ 'FULL-SCREEN)) (FORMAT STREAM "Documentation of ESC keys:~%") - (DOLIST (ITEM (REVERSE KBD-ESC-REPOSITORY)) + (SETQ KBD-ESC-REPOSITORY (SORTCAR KBD-ESC-REPOSITORY #'CHAR-LESSP)) + (DOLIST (ITEM KBD-ESC-REPOSITORY) (KBD-ESC-PRINT-DOCUMENTATION STREAM ITEM)) (FORMAT STREAM "~2%Type a space to flush:") Index: /trunk/lisp/lmio1/relld.lisp =================================================================== --- /trunk/lisp/lmio1/relld.lisp (revision 252) +++ /trunk/lisp/lmio1/relld.lisp (revision 253) @@ -49,5 +49,5 @@ (defvar area-code-list `(temp-area macro-compiled-program nr-sym p-n-string working-storage-area permanent-storage-area - fasl-constants-area)) + fasl-constants-area fasl-constants-area)) ;The high ten bits of a relocatable pointer are the section number. @@ -88,5 +88,5 @@ ;Then comes a halfword containing the number FASL-OP-REL-FILE. -;This tells FASLOAD to call FASL-REL-FILE. +;This tells FASLOAD to call FASL-OP-REL-FILE which calls this loader. ;Then comes a halfword containing the op-code READ-STORAGE-FORMAT-VERSION @@ -110,4 +110,7 @@ ;Then comes a halfword containing zero. +;This causes this loader to exit. +;Then comes a halfword containing FASL-OP-END-OF-FILE, +;or more qfasl format data. ;What are sections? @@ -142,7 +145,8 @@ ;Load a relocatable file from the stream LOAD-STREAM. ;PKG-SPECIFIED is the package argument to FASLOAD, or NIL. -;The other args are the data for bypassing the stream +;The other three args are the data for bypassing the stream ;and reading directly out of the chaosnet buffer. ;They are passed along because FASLOAD already started using them. +;We return the same three quantities, as updated, so FASLOAD can continue. ;See READ-HALFWORD for more information. (defun rel-load-stream (load-stream @@ -163,8 +167,9 @@ (aset (symeval (car l)) area-vector i)) (init-data-type-tables) - (top-level))) + (top-level) + (return stream-array stream-index stream-count))) (defun init-data-type-tables () - (setq data-type-pointer-p (make-array temp-area art-q + (setq data-type-pointer-p (make-array working-storage-area art-q (lsh 1 (logand %%q-data-type 77)))) (aset t data-type-pointer-p dtp-symbol) Index: /trunk/lisp/lmio1/versat.lisp =================================================================== --- /trunk/lisp/lmio1/versat.lisp (revision 252) +++ /trunk/lisp/lmio1/versat.lisp (revision 253) @@ -88,6 +88,6 @@ (DOTIMES (Y H) (LET ((BIT (AREF INPUT-ARRAY (- W X 1) Y))) - (ASET BIT LINE-ARRAY (LOGXOR (* 2 Y) 7)) - (ASET BIT LINE-ARRAY (LOGXOR (1+ (* 2 Y)) 7)))) + (ASET BIT LINE-ARRAY (* 2 Y)) + (ASET BIT LINE-ARRAY (1+ (* 2 Y))))) ;; Now have line in line buffer, print it twice (VERSATEC-WAIT) @@ -129,5 +129,5 @@ (XPOS (+ MARGIN (* SCALE X)))) (DOTIMES (I SCALE) - (ASET BIT LINE-ARRAY (LOGXOR (+ I XPOS) 7))))) + (ASET BIT LINE-ARRAY (+ I XPOS))))) ;; Now have line in line buffer, print it twice (DOTIMES (I SCALE) Index: /trunk/lisp/lmio1/tablet.lisp =================================================================== --- /trunk/lisp/lmio1/tablet.lisp (revision 252) +++ /trunk/lisp/lmio1/tablet.lisp (revision 253) @@ -29,34 +29,13 @@ mouse." (%UNIBUS-WRITE TABLET-CSR 2) - (PROCESS-WAIT "Tablet" - #'(LAMBDA (WAIT-FLAG &AUX CSR) - (SETQ CSR (%UNIBUS-READ TABLET-CSR)) - (SETQ TABLET-BUTTONS (LOGXOR TABLET-MASK - (AR-1 TABLET-MAP-BUTTONS - (LDB %%TABLET-BUTTONS CSR)))) - (COND ((ZEROP (LOGAND CSR %TABLET-BUSY)) - (NOT WAIT-FLAG)) - (( (LOGAND CSR %TABLET-PROXIMITY) 0) - (SETQ TABLET-PROXIMITY 0) ;leaving table. - (NOT WAIT-FLAG)) - (T - (SETQ TABLET-X (// (* (CAR TABLET-X-SCALE) - (LOGAND 177774 (%UNIBUS-READ TABLET-X-REG))) - (CDR TABLET-X-SCALE)) - TABLET-Y (// (* (CAR TABLET-Y-SCALE) - (LOGAND 177774 (%UNIBUS-READ TABLET-Y-REG))) - (CDR TABLET-Y-SCALE))) - (COND ((ZEROP TABLET-PROXIMITY) - (SETQ TABLET-PROXIMITY 1 - TABLET-OLD-X TABLET-X - TABLET-OLD-Y TABLET-Y) ;comming into range - (NOT WAIT-FLAG)) - (T - (NOT (AND (= TABLET-X TABLET-OLD-X) - (= TABLET-Y TABLET-OLD-Y) - (= TABLET-OLD-BUTTONS TABLET-BUTTONS) - WAIT-FLAG))))))) - WAIT-FLAG) + (COND (WAIT-FLAG + (PROCESS-WAIT "Tablet" + #'(LAMBDA () + (TABLET-UPDATE) + (NOT (AND (= TABLET-X TABLET-OLD-X) + (= TABLET-Y TABLET-OLD-Y) + (= TABLET-OLD-BUTTONS TABLET-BUTTONS))))))) (WITHOUT-INTERRUPTS + (COND ((NULL WAIT-FLAG) (TABLET-UPDATE))) (SETQ CHANGED-BUTTONS (LOGXOR TABLET-BUTTONS TABLET-OLD-BUTTONS) TABLET-OLD-BUTTONS TABLET-BUTTONS @@ -70,4 +49,25 @@ (BOOLE 2 TABLET-BUTTONS CHANGED-BUTTONS))) + +(DEFUN TABLET-UPDATE (&AUX CSR) + (SETQ CSR (%UNIBUS-READ TABLET-CSR)) + (SETQ TABLET-BUTTONS (LOGXOR TABLET-MASK + (AR-1 TABLET-MAP-BUTTONS + (LDB %%TABLET-BUTTONS CSR)))) + (COND ;((ZEROP (LOGAND CSR %TABLET-BUSY))) ;gobble most recent data + (( (LOGAND CSR %TABLET-PROXIMITY) 0) + (SETQ TABLET-PROXIMITY 0)) ;leaving table. + (T + (SETQ TABLET-X (// (* (CAR TABLET-X-SCALE) + (LOGAND 177774 (%UNIBUS-READ TABLET-X-REG))) + (CDR TABLET-X-SCALE)) + TABLET-Y (// (* (CAR TABLET-Y-SCALE) + (LOGAND 177774 (%UNIBUS-READ TABLET-Y-REG))) + (CDR TABLET-Y-SCALE))) + (COND ((ZEROP TABLET-PROXIMITY) + (SETQ TABLET-PROXIMITY 1 + TABLET-OLD-X TABLET-X + TABLET-OLD-Y TABLET-Y))) ;comming into range + ))) (DEFUN INSTALL-TABLET (&OPTIONAL (INSTALL-P T)) Index: /trunk/lisp/lmio1/supser.lisp =================================================================== --- /trunk/lisp/lmio1/supser.lisp (revision 252) +++ /trunk/lisp/lmio1/supser.lisp (revision 253) @@ -1,4 +1,5 @@ ;; -*- Mode: Lisp; Package: Supdup; Ibase: 8 -*- ;; Lisp Machine Supdup server -- Old window system only +;; This file is currently broken. ;; SUPDUP-TIMEOUT is time in which the LISTEN must win. Set high for debugging. @@ -42,11 +43,12 @@ ;; Left half fields begin with %TO, right hand with %TP. -(DEFVAR %TOOVR) -(DEFVAR %TOMVU) -(DEFVAR %TORAW 40_18.) ;Suppress cursor motion optimization -(DEFVAR %TOFCI 10_18.) ;Can generate ITS 12-bit character set +(DEFVAR %TOSAI 4000_18.) +(DEFVAR %TOOVR 1000_18.) +(DEFVAR %TOMVU 400_18.) +(DEFVAR %TORAW 40_18.) ;Suppress cursor motion optimization +(DEFVAR %TOFCI 10_18.) ;Can generate ITS 12-bit character set ;%TPCBS (control-back-slash) will also be on -(DEFVAR %TOLID 2_18.) ;Can insert/delete lines -(DEFVAR %TOCID 1_18.) ;Can insert/delete characters +(DEFVAR %TOLID 2_18.) ;Can insert/delete lines +(DEFVAR %TOCID 1_18.) ;Can insert/delete characters ;; ITS 12-bit character representation -- low 7 bits are @@ -68,7 +70,10 @@ 'CHAOS:SERVER-ALIST)) +;; For debugging + +(DEFVAR SUPSER-PROCESSES NIL) +(DEFVAR SUPSER-STREAMS NIL) + ;; This is the top level function of the server process. - -(DECLARE (SPECIAL SUPDUP-PROCESSES FONTS:BIGFNT)) (DEFUN SERVE-SUPDUP (&AUX (CONN (CHAOS:LISTEN "SUPDUP"))) @@ -83,5 +88,6 @@ (SUPDUP-INITIALIZE CONN) (CHAOS:CLOSE CONN)))) - (RETURN-STATE)) + ;; (RETURN-STATE) + ) (T (CHAOS:CLOSE CONN (FORMAT NIL "Connection went into ~S after listening." @@ -101,33 +107,36 @@ (DEFUN SUPDUP-INITIALIZE (CONN &AUX CHAOS-STREAM SUPDUP-STREAM W-O) (SETQ CHAOS-STREAM (CHAOS:STREAM CONN)) - (SEND-GREETING CHAOS-STREAM) + ;; This is apparently a part of the supdup protocol + (FUNCALL CHAOS-STREAM ':STRING-OUT (CHAOS:HOST-DATA CHAOS:MY-ADDRESS)) + (FUNCALL CHAOS-STREAM ':TYO 15) + (FUNCALL CHAOS-STREAM ':TYO 12) + (FUNCALL CHAOS-STREAM ':TYO %TDNOP) + (FUNCALL CHAOS-STREAM ':FORCE-OUTPUT) + (SETQ SUPDUP-STREAM (MAKE-SUPDUP-STREAM CHAOS-STREAM)) (SETQ W-O (FUNCALL SUPDUP-STREAM ':WHICH-OPERATIONS)) - (SETQ SUPDUP-STREAM - (MAKE-EDITOR-STREAM (MAKE-SUPDUP-STREAM CHAOS-STREAM) - ;; Hack Glass ttys here at some point. RWG has one. - (COND ((MEMQ ':SET-CURSORPOS W-O) #'DISPLAY-EDITOR) - (T #'PRINTING-EDITOR)))) - ;; Why this? + (SETQ SUPDUP-STREAM + (SI:MAKE-EDITOR-STREAM SUPDUP-STREAM + ;; Hack Glass ttys here at some point. RWG has one. + (COND ((MEMQ ':SET-CURSORPOS W-O) #'SI:DISPLAY-EDITOR) + (T #'SI:PRINTING-EDITOR)))) (PROCESS-SLEEP 120.) (FUNCALL SUPDUP-STREAM ':CLEAR-SCREEN) + (PRINT-LOADED-BAND SUPDUP-STREAM) + (FUNCALL SUPDUP-STREAM ':STRING-OUT (CHAOS:HOST-DATA CHAOS:MY-ADDRESS)) + (FUNCALL SUPDUP-STREAM ':TYO #\RETURN) + (FUNCALL SUPDUP-STREAM ':FORCE-OUTPUT) + ;; For debugging + (PUSH SUPDUP-STREAM SUPSER-STREAMS) + (PUSH CURRENT-PROCESS SUPSER-PROCESSES) ;; Wake up monitor process - ;; (PUSH CURRENT-PROCESS SUPDUP-PROCESSES) ;; (PREPARE-FOR-SUPDUP) (SUPDUP-TOP-LEVEL SUPDUP-STREAM)) - -(DEFUN SEND-GREETING (STREAM) - (FUNCALL STREAM ':STRING-OUT (CHAOS:HOST-DATA CHAOS:MY-ADDRESS)) - (FUNCALL STREAM ':TYO 15) - (FUNCALL STREAM ':TYO 12) - ;; Why this? - (FUNCALL STREAM ':TYO %TDNOP) - (FUNCALL STREAM ':FORCE-OUTPUT)) ;; A copy of SI:LISP-TOP-LEVEL1 which does a :FORCE-OUTPUT before evaluation. ;; Why is this the right place? ;; Note that the stream to use is passed as an argument and bound to the -;; special variable TERMINAL-IO. *, +, - are bound so as to be per stack group. - -(DEFUN SUPDUP-TOP-LEVEL (TERMINAL-IO &AUX THROW-FLAG VALUES * + -) +;; special variable TERMINAL-IO. - , +, *, etc. are bound so as to be per stack group. + +(DEFUN SUPDUP-TOP-LEVEL (TERMINAL-IO &AUX THROW-FLAG - + ++ +++ * ** *** //) ;; Do forever (DO () (NIL) @@ -139,14 +148,14 @@ (SETQ - (SI:READ-FOR-TOP-LEVEL)) (FUNCALL STANDARD-OUTPUT ':FORCE-OUTPUT) - (LET ((LISP-TOP-LEVEL-INSIDE-EVAL T)) - (SETQ VALUES (MULTIPLE-VALUE-LIST (EVAL -)))) - ;; Save first value and print all values - (SETQ * (FIRST VALUE)) - (DOLIST (VALUE VALUES) + (LET ((SI:LISP-TOP-LEVEL-INSIDE-EVAL T)) + (SETQ // (MULTIPLE-VALUE-LIST (EVAL -)))) + ;; Save first value, list of all values, and previous two values + (SETQ *** ** ** * * (FIRST //)) + (DOLIST (VALUE //) (TERPRI) (FUNCALL (OR PRIN1 #'PRIN1) VALUE))))) ;; Signal return to top level (IF THROW-FLAG (PRINT '*)) - (SETQ + -))) + (SETQ +++ ++ ++ + + -))) (DEFUN 18BIT-IN (STREAM) @@ -174,6 +183,6 @@ ;; Should precede these variable names with SS- or something. -(DECLARE (SPECIAL SUPDUP-CHAOS-STREAM MORE-PROCESSING-FLAG - MORE-PROCESSING-IN-PROGRESS MORE-PROCESSING-LINE +(DECLARE (SPECIAL SUPDUP-CHAOS-STREAM SUPDUP-WHICH-OPERATIONS + MORE-PROCESSING-FLAG MORE-PROCESSING-IN-PROGRESS MORE-PROCESSING-LINE TCTYPE TTYOPT HEIGHT WIDTH TTYROL SMARTS ISPEED OSPEED XPOS YPOS SUPDUP-FINGER-STRING @@ -191,5 +200,5 @@ (DEFUN MAKE-SUPDUP-STREAM (SUPDUP-CHAOS-STREAM) (MULTIPLE-VALUE-BIND (TCTYPE TTYOPT HEIGHT WIDTH TTYROL SMARTS ISPEED OSPEED) - (RECEIVE-TTY-VARIABLES CH-STREAM) + (RECEIVE-TTY-VARIABLES SUPDUP-CHAOS-STREAM) (LET ((SUPDUP-FINGER-STRING) (SUPDUP-WHICH-OPERATIONS) @@ -205,5 +214,5 @@ ;; Set the WHICH-OPERATIONS parameter of the supdup stream according ;; to the terminal capabilities. - (IF (BIT-MEST %TOMVU TTYOPT) + (IF (BIT-TEST %TOMVU TTYOPT) (PUSH-LIST '(:TRIGGER-MORE :READ-CURSORPOS :SET-CURSORPOS :SET-CURSORPOS-RELATIVE :HOME-CURSOR @@ -222,5 +231,5 @@ XPOS YPOS MORE-PROCESSING-FLAG MORE-PROCESSING-IN-PROGRESS MORE-PROCESSING-LINE META-BITS-SEEN - SUPDUP-FINGER-STRING SUPDUP-WHICH-OPERATIONS) + SUPDUP-CHAOS-STREAM SUPDUP-FINGER-STRING SUPDUP-WHICH-OPERATIONS) #'SUPDUP-STREAM)))) @@ -262,5 +271,5 @@ (:READ-CURSORPOS (&OPTIONAL (UNIT ':CHARACTER)) (SELECTQ UNIT - (:CHARACTER (RETURN XPOS YPOS)) + (:CHARACTER (MVRETURN XPOS YPOS)) (OTHERWISE (FERROR NIL "~S is not a known unit." UNIT)))) (:SET-CURSORPOS (X Y &OPTIONAL (UNIT ':CHARACTER)) @@ -337,4 +346,31 @@ ;; a process stuffing characters into an IO-BUFFER. +;; User can set this to change control/meta prefixes. + +(DEFVAR SUPSER-TYI-HOOK 'DEFAULT-SUPSER-TYI-HOOK) + +(DEFUN DEFAULT-SUPSER-TYI-HOOK (CHAR OP) + (COND ((= CHAR #\BREAK) (BREAK BREAK T) NIL) + ((OR (= CHAR #/Z) (= CHAR #/Z)) + (PRINC "Z Quit") + (*THROW 'SI:TOP-LEVEL NIL)) + ;; 12-bit keyboard available + ((BIT-TEST %TOFCI TTYOPT) CHAR) + ;; Ascii keyboard. Accept C-B as break. + ((= CHAR #/B) (BREAK BREAK T) NIL) + ;; C-^ is control prefix,  is meta prefix, C-C is control-meta prefix. + ;; Any prefix typed twice transmits the prefix directly. This doesn't + ;; address the entire character set from Ascii, but its good enough for now. + ((= CHAR #/^) + (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM OP)) + (IF (= CHAR #/^) #/^ (DPB 1 %%KBD-CONTROL CHAR))) + ((= CHAR #/) + (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM OP)) + (IF (= CHAR #/) #/ (DPB 1 %%KBD-META CHAR))) + ((= CHAR #/C) + (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM OP)) + (IF (= CHAR #/C) #/C (DPB 3 %%KBD-CONTROL-META CHAR))) + (T CHAR))) + (DEFUN SUPSER-TYI () (SUPSER-TYI-CHECK-HOOK ':TYI)) (DEFUN SUPSER-TYI-NO-HANG () (SUPSER-TYI-CHECK-HOOK ':TYI-NO-HANG)) @@ -360,4 +396,6 @@ (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM OP)) (COND ((NULL CHAR) (RETURN)) + (( + CHAR 300) (SUPDUP-ESCAPE CHAR)) (( CHAR 34) (RETURN)) (T (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM ':TYI)) @@ -381,32 +419,4 @@ (T (ASCII-TO-LM-CHAR CHAR)))) -;; User can set this to change control/meta prefixes. - -(DEFVAR SUPSER-TYI-HOOK 'DEFAULT-SUPSER-TYI-HOOK) - -(DEFUN DEFAULT-SUPSER-TYI-HOOK (CHAR OP) - (COND ((NULL - ((= CHAR #\BREAK) (BREAK BREAK T) NIL) - ((OR (= CHAR #/Z) (= CHAR #/Z)) - (PRINC "Z Quit") - (*THROW 'SI:TOP-LEVEL NIL)) - ;; 12-bit keyboard available - ((BIT-TEST %TOFCI TTYOPT) CHAR) - ;; Ascii keyboard. Accept C-B as break. - ((= CHAR #/B) (BREAK BREAK T) NIL) - ;; C-^ is control prefix,  is meta prefix, C-C is control-meta prefix. - ;; Any prefix typed twice transmits the prefix directly. This doesn't - ;; address the entire character set from Ascii, but its good enough for now. - ((= CHAR #/^) - (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM OP)) - (IF (= CHAR #/^) #/^ (DPB 1 %%KBD-CONTROL CHAR))) - ((= CHAR #/) - (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM OP)) - (IF (= CHAR #/) #/ (DPB 1 %%KBD-META CHAR))) - ((= CHAR #/C) - (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM OP)) - (IF (= CHAR #/C) #/C (DPB 3 %%KBD-CONTROL-META CHAR))) - (T CHAR))) - ;; Convert C-M to RETURN, C-H to BS, etc. as special cases since it is most likely ;; that the user typed RETURN and BS keys on his keyboard. Don't convert VT to @@ -443,6 +453,6 @@ (DEFUN 12-BIT-TO-LM-CHAR (CHAR &AUX ASC TOP) (SETQ TOP (BIT-TEST %TXTOP CHAR)) - (SETQ CHAR (LOGAND %TXASC CHAR)) - (SETQ CHAR + (SETQ ASC (LOGAND %TXASC CHAR)) + (SETQ ASC (COND (TOP (COND ((< ASC #\SPACE) ASC) ((= ASC #/A) #\ESC) @@ -595,4 +605,7 @@ (SUPSER-RAW-TYO XPOS)) +(DEFUN SUPSER-SET-CURSORPOS-RELATIVE (X Y) + (SUPSER-SET-CURSORPOS (+ XPOS X) (+ YPOS Y))) + ;; Use MORE-PROCESSING-IN-PROGRESS flag to avoid recursion. ;; This should be handled higher up. @@ -602,5 +615,5 @@ (SETQ CHAR (SUPSER-RAW-TYI)) (IF ( CHAR #\SPACE) - (FUNCALL SUPDUP-CHAOS-STRAM ':UNTYI CHAR)) + (FUNCALL SUPDUP-CHAOS-STREAM ':UNTYI CHAR)) ;; Clear out the --More--, home cursor up, and clear the top line. (SUPSER-SET-CURSORPOS 0 YPOS) @@ -692,4 +705,6 @@ ;;; Fancy cpt-monitor display +(declare (special fonts:bigfnt)) + (defclass message-window-class window-with-pc-ppr-class (stream)) Index: /trunk/lisp/lmio1/ctest.lisp =================================================================== --- /trunk/lisp/lmio1/ctest.lisp (revision 252) +++ /trunk/lisp/lmio1/ctest.lisp (revision 253) @@ -1,3 +1,5 @@ ;;-*- MODE: LISP; PACKAGE: USER; IBASE: 10.; BASE: 10. -*- + +;work rotation xfrm (DEFCONST CTEST-BOARD-TYPE 'LG684) ;OR MPG216 @@ -473,4 +475,5 @@ (DEFVAR LG684-JACK-YOFFS NIL) +(DEFVAR DEC-EDGE-XOFFS NIL) ;offset within dec edge connector. (DEFUN LG684-PRNLOC (LOC &AUX ANS) @@ -499,5 +502,5 @@ ANS) -(DEFUN LG684-INIT (&AUX JN DX) +(DEFUN LG684-INIT (&AUX JN DX PN) (SETQ LG684-JACKSZ (MAKE-ARRAY NIL ART-Q 13.)) ;J0 illegal (DOTIMES (C 12.) @@ -523,15 +526,26 @@ (SETQ LG684-PADDLE-XOFFS (MAKE-ARRAY NIL ART-Q 6) LG684-PADDLE-YOFFS (MAKE-ARRAY NIL ART-Q 6)) - (SETQ JN 0 + (SETQ JN 5 DX 0) (DOTIMES (JGROUP 3) (AS-1 DX LG684-PADDLE-XOFFS JN) (AS-1 LG684-DECCNY LG684-PADDLE-YOFFS JN) - (SETQ JN (1+ JN) + (SETQ JN (1- JN) DX (+ DX LG684-DECX1)) (AS-1 DX LG684-PADDLE-XOFFS JN) (AS-1 LG684-DECCNY LG684-PADDLE-YOFFS JN) - (SETQ JN (1+ JN) - DX (+ DX LG684-DECX2)))) + (SETQ JN (1- JN) + DX (+ DX LG684-DECX2))) + (SETQ DEC-EDGE-XOFFS (MAKE-ARRAY NIL ART-Q 18.)) + (SETQ DX 0 + PN 17.) + (DOTIMES (PGROUP 3) + (AS-1 DX DEC-EDGE-XOFFS PN) + (SETQ PN (1- PN)) + (DOTIMES (C 5) + (SETQ DX (+ DX LG684-DCPNSP)) + (AS-1 DX DEC-EDGE-XOFFS PN) + (SETQ PN (1- PN))) + (SETQ DX (+ DX LG684-DCGRSP)))) (DEFUN LG684-GETLOC (STR BEG LIM &AUX C VAL-LIST IDX) @@ -565,5 +579,5 @@ (5 (SI:DESTRUCTURING-BIND (LET PADDLE-LET PADDLE-SIDE) VAL-LIST (DPB LET LG684-%CONN - (DPB (+ (LSH (CTEST-DEC-LETTER-TO-NUMBER PADDLE-LET) 1) + (DPB (+ (LSH PADDLE-LET 1) ;already dec-letter hacked (1- PADDLE-SIDE)) CTEST-%%PIN @@ -596,5 +610,5 @@ (FERROR NIL "bad conn number")) (SETQ X (+ X (AR-1 LG684-PADDLE-XOFFS (1- CONN)) - (* LG684-DCPNSP (LSH PIN -1))) + (AR-1 DEC-EDGE-XOFFS (1- (LSH PIN -1)))) Y (+ Y (AR-1 LG684-PADDLE-YOFFS (1- CONN)) (* LG684-DCPINO (LOGAND PIN 1))))) @@ -606,5 +620,6 @@ (AR-1 LG684-JACK-YOFFS CONN))) ))) - (return x y))) + (return (- 9000 x) (- 17000 y) +))) ;board fits in tester backwards .. @@ -617,4 +632,5 @@ (DEFUN CTEST-DEC-LETTER-TO-NUMBER (NUM) + (SETQ NUM (+ NUM #/@)) (COND ((MEMQ NUM '(#/G #/I #/O #/Q)) (FERROR NIL "~C invalid DEC letter" NUM))) @@ -623,4 +639,5 @@ (IF (> NUM #/I) (SETQ NUM (1- NUM))) (IF (> NUM #/G) (SETQ NUM (1- NUM))) + (SETQ NUM (- NUM #/@)) NUM) Index: /trunk/lisp/lmio1/reldmp.lisp =================================================================== --- /trunk/lisp/lmio1/reldmp.lisp (revision 252) +++ /trunk/lisp/lmio1/reldmp.lisp (revision 253) @@ -250,8 +250,6 @@ (let ((total-len (%structure-total-size object)) (boxed-len (%structure-boxed-size object)) - (start-offset (cond ((and (arrayp object) - (array-has-leader-p object)) - (- (+ 2 (array-leader-length object)))) - (t 0)))) + (start-offset (%pointer-difference (%find-structure-leader object) + object))) (let ((index (allocate-section-space secnum total-len)) (array (aref dump-section-array-table secnum))) Index: /trunk/lisp/lmio1/xfed.lisp =================================================================== --- /trunk/lisp/lmio1/xfed.lisp (revision 252) +++ /trunk/lisp/lmio1/xfed.lisp (revision 253) @@ -1,3 +1,3 @@ -;;; -*-LISP-*- +;;; -*-Mode:LISP;Package:FED-*- (SPECIAL FED-WINDOW FED-FD-ALIST FED-WINDOW-CLASS) Index: /trunk/lisp/lmio1/press.lisp =================================================================== --- /trunk/lisp/lmio1/press.lisp (revision 252) +++ /trunk/lisp/lmio1/press.lisp (revision 253) @@ -589,5 +589,5 @@ X X1) STOP)) ;; If Y would be below the line, use CH1 else use CH2 - (IF (< (// (SMALL-FLOAT (+ Y CDY2)) (+ X CDX2)) SLOPE) + (IF (< (// (SMALL-FLOAT (- (+ Y CDY2) Y0)) (- (+ X CDX2) X0)) SLOPE) (SETQ CH CH1 XINC CDX1 YINC CDY1) (SETQ CH CH2 XINC CDX2 YINC CDY2)) Index: /trunk/lisp/lmio1/fntcnv.lisp =================================================================== --- /trunk/lisp/lmio1/fntcnv.lisp (revision 252) +++ /trunk/lisp/lmio1/fntcnv.lisp (revision 253) @@ -346,5 +346,5 @@ (or fontname (setq fontname (funcall filename ':name))) (and (stringp fontname) (setq fontname (intern fontname "FONTS"))) - (setq stream (open fielname '(:fixnum :in :byte-size 9.))) + (setq stream (open filename '(:fixnum :in :byte-size 9.))) (setq fd (make-font-descriptor fd-name fontname)) ;; Discard KSTID. Index: /trunk/lisp/lmio1/fed.lisp =================================================================== --- /trunk/lisp/lmio1/fed.lisp (revision 252) +++ /trunk/lisp/lmio1/fed.lisp (revision 253) @@ -577,5 +577,5 @@ FD-SPACE-WIDTH 7)) (AS-1 (MAKE-CHAR-DESCRIPTOR - MAKE-ARRAY (DEFAULT-ARRAY-AREA ART-4B '(11 7)) + MAKE-ARRAY (NIL ART-4B '(11 7)) CD-CHAR-WIDTH 7 CD-CHAR-LEFT-KERN 0) @@ -857,5 +857,5 @@ ;; Copy the data in the FED buffer into a CD (SETQ CD (MAKE-CHAR-DESCRIPTOR - MAKE-ARRAY (DEFAULT-ARRAY-AREA ART-4B (LIST YWIDTH XWIDTH)) + MAKE-ARRAY (NIL ART-4B (LIST YWIDTH XWIDTH)) CD-CHAR-WIDTH (- CHAR-BOX-X2 CHAR-BOX-X1) CD-CHAR-LEFT-KERN KERN)) Index: /trunk/lisp/lmio1/time.lisp =================================================================== --- /trunk/lisp/lmio1/time.lisp (revision 252) +++ /trunk/lisp/lmio1/time.lisp (revision 253) @@ -115,5 +115,5 @@ (LET ((B (\ (+ YEAR 1899.) 400.))) (\ (- (+ (1+ B) (SETQ B (// B 4))) (// B 25.)) 7))) - (FEB29 (IF (ZEROP (\ YEAR 4)) 1 0))) ;Good enough for this century, and the next + (FEB29 (IF (LEAP-YEAR-P YEAR) 1 0))) (LET ((DOW-APRIL-30 (\ (+ DOW-BEG-YEAR 119. FEB29) 7))) (- 30. DOW-APRIL-30)))) @@ -127,5 +127,5 @@ (SETQ TEM (+ (1- DAY) (AREF *CUMULATIVE-MONTH-DAYS-TABLE* MONTH) (// (1- YEAR) 4) (* YEAR 365.))) ;Number of days since 1/1/00. - (AND (> MONTH 2) (ZEROP (\ YEAR 4)) + (AND (> MONTH 2) (LEAP-YEAR-P YEAR) (SETQ TEM (1+ TEM))) ;After 29-Feb in a leap year. (+ SECONDS (* TEM 86400.) (* TIMEZONE 3600.))) ;Return number of seconds. @@ -178,10 +178,12 @@ (SETQ *LAST-TIME-MINUTES* (\ *LAST-TIME-MINUTES* 60.))) 24.) - (< (PROG1 (SETQ *LAST-TIME-DAY* (1+ *LAST-TIME-DAY*)) + ( + (PROG1 (SETQ *LAST-TIME-DAY* (1+ *LAST-TIME-DAY*)) (SETQ *LAST-TIME-DAY-OF-THE-WEEK* (\ (1+ *LAST-TIME-DAY-OF-THE-WEEK*) 7)) (SETQ *LAST-TIME-HOURS* 0)) (MONTH-LENGTH *LAST-TIME-MONTH* *LAST-TIME-YEAR*)) - (< (SETQ *LAST-TIME-DAY* 1 + ( + (SETQ *LAST-TIME-DAY* 1 *LAST-TIME-MONTH* (1+ *LAST-TIME-MONTH*)) 12.) @@ -199,6 +201,11 @@ (DEFUN MONTH-LENGTH (MONTH YEAR) (IF (= MONTH 2) - (IF (ZEROP (\ YEAR 4)) 29. 28.) + (IF (LEAP-YEAR-P YEAR) 29. 28.) (NTH MONTH *MONTH-LENGTHS*))) + +(DEFUN LEAP-YEAR-P (YEAR) + (AND (ZEROP (\ YEAR 4)) + (OR (NOT (ZEROP (\ YEAR 100.))) + (ZEROP (\ YEAR 400.))))) (DEFUN DAYLIGHT-SAVINGS-P () @@ -471,13 +478,10 @@ (SETQ MONTH (// TOKEN 100.) DAY (\ TOKEN 100.)) - (COND (( - DAY 12.)) - ((OR ( - MONTH 12.) AMBIGUOUS-ASSUME-DAY-FIRST) + (COND ((> DAY 12.)) + ((OR (> MONTH 12.) AMBIGUOUS-ASSUME-DAY-FIRST) (PSETQ DAY MONTH MONTH DAY))) (SETQ STATE (IF YEAR ':DONE ':DAY-AND-MONTH-SEEN))) (T - (IF ( - TOKEN 12.) + (IF (> TOKEN 12.) (SETQ DAY TOKEN) (SETQ MONTH TOKEN)) Index: /trunk/lisp/lmio1/dplt.lisp =================================================================== --- /trunk/lisp/lmio1/dplt.lisp (revision 252) +++ /trunk/lisp/lmio1/dplt.lisp (revision 253) @@ -76,5 +76,6 @@ (:COPIES (SETQ COPIES (CADR L))) (:FILE (SETQ SPOOL-FILENAME - (SI:FILE-MERGE-PATHNAMES (CADR L) SPOOL-FILENAME))) + (AND (CADR L) + (SI:FILE-MERGE-PATHNAMES (CADR L) SPOOL-FILENAME)))) (:BLANK-PAGE (SETQ BLANK-PAGE T)) (T (FERROR NIL "~%~A Unknown keyword: DPLT:PRINT-FILE" (CAR L)))) Index: /trunk/lisp/lmio1/fntdef.lisp =================================================================== --- /trunk/lisp/lmio1/fntdef.lisp (revision 252) +++ /trunk/lisp/lmio1/fntdef.lisp (revision 253) @@ -5,5 +5,5 @@ (DEFSTRUCT (FONT-DESCRIPTOR :ARRAY-LEADER :NAMED - (:MAKE-ARRAY (DEFAULT-ARRAY-AREA 'ART-Q 200))) + (:MAKE-ARRAY (NIL 'ART-Q 200))) FD-FILL-POINTER FD-NAME