Changeset 253


Ignore:
Timestamp:
08/18/11 15:08:01 (3 years ago)
Author:
rjs
Message:

Update.

Location:
trunk/lisp/lmio1
Files:
1 added
21 edited

Legend:

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

    r252 r253  
    99
    1010(DEFVAR MILLS-TO-STEPS NIL)
     11
     12(DECLARE (SPECIAL CTEST-BOARD-TYPE))
    1113
    1214(DECLARE (SPECIAL MPG216-GXOFST))
     
    629631        (COND ((NULL MILLS-TO-STEPS)
    630632               (SETQ MILLS-TO-STEPS (// 1434. (FLOAT (* 5 MPG216-GXOFST))))))
    631         (FORMAT T "~%Position ~S probe over 1A01-10" NAME)
     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)
    632637        (<- SELF ':MANUAL-CONTROL)
    633638        (<- SELF ':probe-up)
    634         (FORMAT T "~%RECOMPUTE MILLS-TO-STEPS?")
    635         (COND ((Y-OR-N-P)
     639        (COND ((Y-OR-N-P "RECOMPUTE MILLS-TO-STEPS?")
    636640               (<- self ':manual-control)
    637                (FORMAT T "~%Now position it over 1F01-10")
     641               (FORMAT T (SELECTQ CTEST-BOARD-TYPE
     642                           (MPG216 "~%Now position it over 1F01-10")
     643                           (LG684 "~%Now position it over A30-10")))
    638644               (<- SELF ':probe-up)
    639645               (MULTIPLE-VALUE (XD YD) (<- self ':manual-control ctest-slow-speed))
    640646               (FORMAT T "~%That was ~d xsteps, ~d ysteps" XD YD)
    641                (SETQ MILLS-TO-STEPS (// YD (FLOAT (* 5 MPG216-GXOFST))))
    642                (SETQ POS "1F01-10")
     647               (SETQ MILLS-TO-STEPS (// YD (FLOAT
     648                                             (SELECTQ CTEST-BOARD-TYPE
     649                                               (MPG216 (* 5 MPG216-GXOFST))
     650                                               (LG684 (* 30. LG684-XDIPSP))))))
     651               (SETQ POS (SELECTQ CTEST-BOARD-TYPE
     652                           (MPG216 "1F01-10")
     653                           (LG684 "A30-10")))
    643654               (<- SELF ':DEFINE-POSITION-STRING-LOC POS))
    644               (T (SETQ POS "1A01-10")
     655              (T (SETQ POS (SELECTQ CTEST-BOARD-TYPE
     656                             (MPG216 "1A01-10")
     657                             (LG684 "A1-10")))
    645658                 (<- SELF ':DEFINE-POSITION-STRING-LOC POS)))
    646659        (COND (REDO-CALIB
    647                (FORMAT T "~%HOW MANY BOARDS?")
    648                (SETQ NBOARDS (READ))
    649                (DOTIMES (C NBOARDS)
    650                  (CALIBRATE-AT-LOC (1+ C) (FORMAT NIL "~DA1-10" (1+ C)) CALIBRATOR)
    651                  (CALIBRATE-AT-LOC (1+ C) (FORMAT NIL "~DF1-10" (1+ C)) CALIBRATOR))
    652 ;               (CALIBRATE-AT-LOC NBOARDS (FORMAT NIL "~DA15-10" NBOARDS) CALIBRATOR)
    653 ;               (CALIBRATE-AT-LOC NBOARDS (FORMAT NIL "~DF11-10" NBOARDS) CALIBRATOR)
    654                 (CALIBRATE-AT-LOC NBOARDS (FORMAT NIL "~DA30-10" NBOARDS) CALIBRATOR)
    655                 (CALIBRATE-AT-LOC NBOARDS (FORMAT NIL "~DF25-10" NBOARDS) CALIBRATOR)))
     660               (SELECTQ CTEST-BOARD-TYPE
     661                 (MPG216
     662                  (FORMAT T "~%HOW MANY BOARDS?")
     663                  (SETQ NBOARDS (READ))
     664                  (DOTIMES (C NBOARDS)
     665                    (CALIBRATE-AT-LOC (1+ C) (FORMAT NIL "~DA1-10" (1+ C)) CALIBRATOR)
     666                    (CALIBRATE-AT-LOC (1+ C) (FORMAT NIL "~DF1-10" (1+ C)) CALIBRATOR))
     667                  (CALIBRATE-AT-LOC NBOARDS (FORMAT NIL "~DA30-10" NBOARDS) CALIBRATOR)
     668                  (CALIBRATE-AT-LOC NBOARDS (FORMAT NIL "~DF25-10" NBOARDS) CALIBRATOR))
     669                 (LG684
     670                  (CALIBRATE-AT-LOC 1 "F1-10" CALIBRATOR)
     671                  (CALIBRATE-AT-LOC 1 "F30-10" CALIBRATOR)))))
    656672        (PRINT-CALIBRATION)))
    657673           
    658674(DEFMETHOD (PROBE-CLASS :RECALIBRATE-BOARD) (BOARD-NUM
    659     &OPTIONAL AUTO-FLAG (LOCS '("A1-10" "F1-10" "A29-10" "F26-10")))
     675    &OPTIONAL AUTO-FLAG (LOCS (SELECTQ CTEST-BOARD-TYPE
     676                                (MPG216 '("A1-10" "F1-10" "A29-10" "F26-10"))
     677                                (LG684 '("A1-10" "A1-30" "F1-10" "F1-30")))))
    660678  (<- CALIBRATOR ':FLUSH-CALIBRATION-FOR-BOARD BOARD-NUM)
    661679  (DOLIST (L LOCS)
    662680    (CALIBRATE-AT-LOC BOARD-NUM
    663                       (STRING-APPEND (FORMAT NIL "~D" BOARD-NUM) L)
     681                      (SELECTQ CTEST-BOARD-TYPE
     682                        (MPG216 (STRING-APPEND (FORMAT NIL "~D" BOARD-NUM) L))
     683                        (LG684 L))
    664684                      CALIBRATOR
    665685                      AUTO-FLAG)
     
    758778                ((EQ CH #\RUBOUT)
    759779                 (RETURN T)))
    760           (COND ((BIT-TEST BD 1)
     780          (COND ((NULL BD) (GO L))
     781                ((BIT-TEST BD 1)
    761782                 (<- SELF (COND (DOWN-P ':PROBE-UP)
    762783                                (T ':PROBE-DOWN))))
     
    772793 )
    773794
    774 (DEFUN MOVE-CHAR-TYI-OR-MOUSE-BUTTON NIL
    775  TV:(PROG (NEW-BUTTONS CHANGED-BUTTONS)
     795(DEFUN MOVE-CHAR-OR-TYI-OR-MOUSE-BUTTON (&OPTIONAL (TV:STREAM STANDARD-INPUT))
     796 TV:(PROG (NEW-BUTTONS CHANGED-BUTTONS IO-BUFFER)
     797         (SETQ IO-BUFFER (FUNCALL STREAM ':IO-BUFFER))
    776798      L  (PROCESS-ALLOW-SCHEDULE)
    777799         (PROCESS-WAIT "mouse"
    778                        #'(LAMBDA (&AUX (NH1 ))
    779                            (OR ()
     800                       #'(LAMBDA (IO-BUFFER)
     801                           (OR (NULL (IO-BUFFER-EMPTY-P IO-BUFFER))
     802                               (IF (EQ IO-BUFFER (KBD-GET-IO-BUFFER))
     803                                   (NULL (IO-BUFFER-EMPTY-P KBD-IO-BUFFER)))
    780804                               ( MOUSE-LAST-BUTTONS
    781                                   (LDB 1403 (%UNIBUS-READ MOUSE-REG1))))))
     805                                  (LDB 1403 (%UNIBUS-READ MOUSE-REG1)))))
     806                       IO-BUFFER)
     807         (IF (FUNCALL STREAM ':LISTEN)
     808             (LET ((CH (FUNCALL STREAM ':TYI)))
     809               (MULTIPLE-VALUE-BIND (DX DY) (USER:KEYSTROKE-MOVE-DELTA CH)
     810                 (IF (NULL DX)
     811                     (RETURN CH)
     812                     (RETURN NIL NIL DX DY)))))
     813         (SETQ NEW-BUTTONS (MOUSE-BUTTONS)
     814               CHANGED-BUTTONS (LOGXOR NEW-BUTTONS MOUSE-LAST-BUTTONS)
     815               MOUSE-LAST-BUTTONS NEW-BUTTONS)
     816         (IF (ZEROP (LOGAND NEW-BUTTONS CHANGED-BUTTONS))
     817             (GO L)
     818             (RETURN NIL (LOGAND NEW-BUTTONS CHANGED-BUTTONS))))
    782819  )
    783820
  • trunk/lisp/lmio1/chatst.lisp

    r252 r253  
    174174      (DO () ((LDB-TEST %%CHAOS-CSR-RECEIVE-DONE
    175175                        (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))))
    176       (PROCESS-SLEEP 30.))  ;Give it time to arrive
     176      (PROCESS-SLEEP 10.))  ;Give it time to arrive
    177177  (SETQ CSR (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))
    178178  (SETQ ME (%UNIBUS-READ MY-NUMBER-REGISTER-TEST))
     179  (IF (NOT (ZEROP (LDB-TEST %%CHAOS-CSR-TRANSMIT-ABORT CSR)))
     180      (FORMAT t "~%Transmit aborted, then~%"))
    179181  (COND ((NOT (LDB-TEST %%CHAOS-CSR-RECEIVE-DONE CSR))
    180182         (SETQ LOSE T) (PRINT 'NO-RECEIVE))
    181         ((LDB-TEST %%CHAOS-CSR-TRANSMIT-ABORT CSR)
    182          (SETQ LOSE T) (PRINT 'TRANSMIT-ABORT))
    183183        (T (AND (LDB-TEST %%CHAOS-CSR-CRC-ERROR CSR)
    184184                (PROGN (SETQ LOSE T)
  • trunk/lisp/lmio1/ctest.lisp

    r252 r253  
    11;;-*- MODE: LISP; PACKAGE: USER; IBASE: 10.; BASE: 10. -*-
     2
     3;work rotation xfrm
    24
    35(DEFCONST CTEST-BOARD-TYPE 'LG684)  ;OR MPG216
     
    474476(DEFVAR LG684-JACK-YOFFS NIL)
    475477
     478(DEFVAR DEC-EDGE-XOFFS NIL)    ;offset within dec edge connector.
    476479
    477480(DEFUN LG684-PRNLOC (LOC &AUX ANS)
     
    500503  ANS)
    501504
    502 (DEFUN LG684-INIT (&AUX JN DX)
     505(DEFUN LG684-INIT (&AUX JN DX PN)
    503506  (SETQ LG684-JACKSZ (MAKE-ARRAY NIL ART-Q 13.))        ;J0 illegal
    504507  (DOTIMES (C 12.)
     
    524527  (SETQ LG684-PADDLE-XOFFS (MAKE-ARRAY NIL ART-Q 6)
    525528        LG684-PADDLE-YOFFS (MAKE-ARRAY NIL ART-Q 6))
    526   (SETQ JN 0
     529  (SETQ JN 5
    527530        DX 0) 
    528531  (DOTIMES (JGROUP 3)
    529532    (AS-1 DX LG684-PADDLE-XOFFS JN)
    530533    (AS-1 LG684-DECCNY LG684-PADDLE-YOFFS JN)
    531     (SETQ JN (1+ JN)
     534    (SETQ JN (1- JN)
    532535          DX (+ DX LG684-DECX1))
    533536    (AS-1 DX LG684-PADDLE-XOFFS JN)
    534537    (AS-1 LG684-DECCNY LG684-PADDLE-YOFFS JN)
    535     (SETQ JN (1+ JN)
    536           DX (+ DX LG684-DECX2))))
     538    (SETQ JN (1- JN)
     539          DX (+ DX LG684-DECX2)))
     540  (SETQ DEC-EDGE-XOFFS (MAKE-ARRAY NIL ART-Q 18.))
     541  (SETQ DX 0
     542        PN 17.)
     543  (DOTIMES (PGROUP 3)
     544    (AS-1 DX DEC-EDGE-XOFFS PN)
     545    (SETQ PN (1- PN))
     546    (DOTIMES (C 5)
     547      (SETQ DX (+ DX LG684-DCPNSP))
     548      (AS-1 DX DEC-EDGE-XOFFS PN)
     549      (SETQ PN (1- PN)))
     550    (SETQ DX (+ DX LG684-DCGRSP))))
    537551
    538552(DEFUN LG684-GETLOC (STR BEG LIM &AUX C VAL-LIST IDX)
     
    566580    (5 (SI:DESTRUCTURING-BIND (LET PADDLE-LET PADDLE-SIDE) VAL-LIST
    567581                              (DPB LET LG684-%CONN
    568                                    (DPB (+ (LSH (CTEST-DEC-LETTER-TO-NUMBER PADDLE-LET) 1)
     582                                   (DPB (+ (LSH PADDLE-LET 1)  ;already dec-letter hacked
    569583                                           (1- PADDLE-SIDE))
    570584                                        CTEST-%%PIN
     
    597611                   (FERROR NIL "bad conn number"))
    598612               (SETQ X (+ X (AR-1 LG684-PADDLE-XOFFS (1- CONN))
    599                           (* LG684-DCPNSP (LSH PIN -1)))
     613                          (AR-1 DEC-EDGE-XOFFS (1- (LSH PIN -1))))
    600614                     Y (+ Y (AR-1 LG684-PADDLE-YOFFS (1- CONN))
    601615                          (* LG684-DCPINO (LOGAND PIN 1)))))
     
    607621                              (AR-1 LG684-JACK-YOFFS CONN)))
    608622                   )))
    609         (return x y)))
     623        (return (- 9000 x) (- 17000 y)
     624)))  ;board fits in tester backwards ..
    610625
    611626
     
    618633
    619634(DEFUN CTEST-DEC-LETTER-TO-NUMBER (NUM)
     635  (SETQ NUM (+ NUM #/@))
    620636  (COND ((MEMQ NUM '(#/G #/I #/O #/Q))
    621637         (FERROR NIL "~C invalid DEC letter" NUM)))
     
    624640  (IF (> NUM #/I) (SETQ NUM (1- NUM)))
    625641  (IF (> NUM #/G) (SETQ NUM (1- NUM)))
     642  (SETQ NUM (- NUM #/@))
    626643  NUM)
    627644
  • trunk/lisp/lmio1/dplt.lisp

    r252 r253  
    7777                   (:COPIES (SETQ COPIES (CADR L)))
    7878                   (:FILE  (SETQ SPOOL-FILENAME
    79                                  (SI:FILE-MERGE-PATHNAMES (CADR L) SPOOL-FILENAME)))
     79                                 (AND (CADR L)
     80                                      (SI:FILE-MERGE-PATHNAMES (CADR L) SPOOL-FILENAME))))
    8081                   (:BLANK-PAGE (SETQ BLANK-PAGE T))
    8182                   (T (FERROR NIL "~%~A Unknown keyword: DPLT:PRINT-FILE" (CAR L))))
  • trunk/lisp/lmio1/draw.lisp

    r252 r253  
    1 ;USER FUNCTIONS:                        -*-lisp-*-
     1;                       -*-lisp-*-
     2;       ** (c) Copyright 1980 Massachusetts Institute of Technology **
     3
     4;USER FUNCTIONS:
    25; (DRAW-LINE initial-X initial-Y final-X final-Y &OPTIONAL mode)
    36; (DRAW-CIRCLE center-X center-Y radius &OPTIONAL mode)
  • trunk/lisp/lmio1/escape.lisp

    r252 r253  
    140140                            'FULL-SCREEN))
    141141  (FORMAT STREAM "Documentation of ESC keys:~%")
    142   (DOLIST (ITEM (REVERSE KBD-ESC-REPOSITORY))
     142  (SETQ KBD-ESC-REPOSITORY (SORTCAR KBD-ESC-REPOSITORY #'CHAR-LESSP))
     143  (DOLIST (ITEM KBD-ESC-REPOSITORY)
    143144    (KBD-ESC-PRINT-DOCUMENTATION STREAM ITEM))
    144145  (FORMAT STREAM "~2%Type a space to flush:")
  • trunk/lisp/lmio1/fed.lisp

    r252 r253  
    585585                                            FD-SPACE-WIDTH 7))
    586586             (AS-1 (MAKE-CHAR-DESCRIPTOR
    587                     MAKE-ARRAY (DEFAULT-ARRAY-AREA ART-4B '(11 7))
     587                    MAKE-ARRAY (NIL ART-4B '(11 7))
    588588                    CD-CHAR-WIDTH 7
    589589                    CD-CHAR-LEFT-KERN 0)
     
    867867    ;; Copy the data in the FED buffer into a CD
    868868    (SETQ CD (MAKE-CHAR-DESCRIPTOR
    869                       MAKE-ARRAY (DEFAULT-ARRAY-AREA ART-4B (LIST YWIDTH XWIDTH))
     869                      MAKE-ARRAY (NIL ART-4B (LIST YWIDTH XWIDTH))
    870870                      CD-CHAR-WIDTH (- CHAR-BOX-X2 CHAR-BOX-X1)
    871871                      CD-CHAR-LEFT-KERN KERN))
  • trunk/lisp/lmio1/fntcnv.lisp

    r252 r253  
    351351  (or fontname (setq fontname (funcall filename ':name)))
    352352  (and (stringp fontname) (setq fontname (intern fontname "FONTS")))
    353   (setq stream (open fielname '(:fixnum :in :byte-size 9.)))
     353  (setq stream (open filename '(:fixnum :in :byte-size 9.)))
    354354  (setq fd (make-font-descriptor fd-name fontname))
    355355  ;; Discard KSTID.
  • trunk/lisp/lmio1/fntdef.lisp

    r252 r253  
    55
    66(DEFSTRUCT (FONT-DESCRIPTOR :ARRAY-LEADER :NAMED
    7                                   (:MAKE-ARRAY (DEFAULT-ARRAY-AREA 'ART-Q 200)))
     7                                  (:MAKE-ARRAY (NIL 'ART-Q 200)))
    88           FD-FILL-POINTER
    99           FD-NAME
  • trunk/lisp/lmio1/hacks.lisp

    r252 r253  
    1 ;-*-LISP-*-
     1;-*-MODE: LISP; PACKAGE: USER; BASE: 8-*-
    22;       ** (c) Copyright 1980 Massachusetts Institute of Technology **
    33
  • trunk/lisp/lmio1/press.lisp

    r252 r253  
    599599 X X1) STOP))
    600600                ;; If Y would be below the line, use CH1 else use CH2
    601                 (IF (< (// (SMALL-FLOAT (+ Y CDY2)) (+ X CDX2)) SLOPE)
     601                (IF (< (// (SMALL-FLOAT (- (+ Y CDY2) Y0)) (- (+ X CDX2) X0)) SLOPE)
    602602                    (SETQ CH CH1 XINC CDX1 YINC CDY1)
    603603                    (SETQ CH CH2 XINC CDX2 YINC CDY2))
  • trunk/lisp/lmio1/reldmp.lisp

    r252 r253  
    254254    (let ((total-len (%structure-total-size object))
    255255          (boxed-len (%structure-boxed-size object))
    256           (start-offset (cond ((and (arrayp object)
    257                                     (array-has-leader-p object))
    258                                (- (+ 2 (array-leader-length object))))
    259                               (t 0))))
     256          (start-offset (%pointer-difference (%find-structure-leader object)
     257                                             object)))
    260258      (let ((index (allocate-section-space secnum total-len))
    261259            (array (aref dump-section-array-table secnum)))
  • trunk/lisp/lmio1/relld.lisp

    r252 r253  
    4949(defvar area-code-list `(temp-area macro-compiled-program nr-sym p-n-string
    5050                                working-storage-area permanent-storage-area
    51                                 fasl-constants-area))
     51                                fasl-constants-area fasl-constants-area))
    5252
    5353;The high ten bits of a relocatable pointer are the section number.
     
    8989
    9090;Then comes a halfword containing the number FASL-OP-REL-FILE.
    91 ;This tells FASLOAD to call FASL-REL-FILE.
     91;This tells FASLOAD to call FASL-OP-REL-FILE which calls this loader.
    9292
    9393;Then comes a halfword containing the op-code READ-STORAGE-FORMAT-VERSION
     
    111111
    112112;Then comes a halfword containing zero.
     113;This causes this loader to exit.
     114;Then comes a halfword containing FASL-OP-END-OF-FILE,
     115;or more qfasl format data.
    113116
    114117;What are sections?
     
    144147;Load a relocatable file from the stream LOAD-STREAM.
    145148;PKG-SPECIFIED is the package argument to FASLOAD, or NIL.
    146 ;The other args are the data for bypassing the stream
     149;The other three args are the data for bypassing the stream
    147150;and reading directly out of the chaosnet buffer.
    148151;They are passed along because FASLOAD already started using them.
     152;We return the same three quantities, as updated, so FASLOAD can continue.
    149153;See READ-HALFWORD for more information.
    150154(defun rel-load-stream (load-stream
     
    165169          (aset (symeval (car l)) area-vector i))
    166170        (init-data-type-tables)
    167         (top-level)))
     171        (top-level)
     172        (return stream-array stream-index stream-count)))
    168173
    169174(defun init-data-type-tables ()
    170   (setq data-type-pointer-p (make-array temp-area art-q
     175  (setq data-type-pointer-p (make-array working-storage-area art-q
    171176                                        (lsh 1 (logand %%q-data-type 77))))
    172177  (aset t data-type-pointer-p dtp-symbol)
  • trunk/lisp/lmio1/rfontw.lisp

    r252 r253  
    178178      (cond ((not (zerop (boole 1 100000 m)))
    179179             (setq xwidths (next-word)))
    180             (t (setq xwidths (*array nil 'fixnum 200))
     180            (t (setq xwidths (*array nil 'fixnum 400))
    181181               (fillarray xwidths '(-1))        ;Chars not in bc..ec have -1
    182182               (do ((j (caddr seg) (1+ j))
     
    189189      (cond ((not (zerop (boole 1 40000 m)))
    190190             (setq ywidths (next-word)))
    191             (t (setq ywidths (*array nil 'fixnum 200))
     191            (t (setq ywidths (*array nil 'fixnum 400))
    192192               (fillarray xwidths '(-1))        ;Chars not in bc..ec have -1
    193193               (do ((j (caddr seg) (1+ j))
     
    236236    (cond ((not (zerop (caddr dat)))    ;Already got data in micas
    237237           (cond ((numberp xwidths)     ;Fixed-width font
    238                   (setq tem (*array nil 'fixnum 200))
     238                  (setq tem (*array nil 'fixnum 400))
    239239                  (fillarray tem (list xwidths))
    240240                  (setq xwidths tem)))
     
    242242          ((numberp xwidths)            ;Fixed-width font
    243243           (setq tem (// (* xwidths 2540. point-size) 72000.))
    244            (setq xwidths (*array nil 'fixnum 200))
     244           (setq xwidths (*array nil 'fixnum 400))
    245245           (fillarray xwidths (list tem))
    246246           xwidths)                 
  • trunk/lisp/lmio1/supser.lisp

    r252 r253  
    11;; -*- Mode: Lisp; Package: Supdup; Ibase: 8 -*-
    22;; Lisp Machine Supdup server -- Old window system only
     3;; This file is currently broken.
    34
    45;; SUPDUP-TIMEOUT is time in which the LISTEN must win.  Set high for debugging.
     
    4243;; Left half fields begin with %TO, right hand with %TP.
    4344
    44 (DEFVAR %TOOVR)
    45 (DEFVAR %TOMVU)
    46 (DEFVAR %TORAW 40_18.)      ;Suppress cursor motion optimization
    47 (DEFVAR %TOFCI 10_18.)      ;Can generate ITS 12-bit character set
     45(DEFVAR %TOSAI 4000_18.)
     46(DEFVAR %TOOVR 1000_18.)
     47(DEFVAR %TOMVU  400_18.)
     48(DEFVAR %TORAW   40_18.)    ;Suppress cursor motion optimization
     49(DEFVAR %TOFCI   10_18.)    ;Can generate ITS 12-bit character set
    4850                            ;%TPCBS (control-back-slash) will also be on
    49 (DEFVAR %TOLID  2_18.)      ;Can insert/delete lines
    50 (DEFVAR %TOCID  1_18.)      ;Can insert/delete characters
     51(DEFVAR %TOLID    2_18.)    ;Can insert/delete lines
     52(DEFVAR %TOCID    1_18.)    ;Can insert/delete characters
    5153
    5254;; ITS 12-bit character representation -- low 7 bits are
     
    6870                      'CHAOS:SERVER-ALIST))
    6971
     72;; For debugging
     73
     74(DEFVAR SUPSER-PROCESSES NIL)
     75(DEFVAR SUPSER-STREAMS NIL)
     76
    7077;; This is the top level function of the server process.
    71 
    72 (DECLARE (SPECIAL SUPDUP-PROCESSES FONTS:BIGFNT))
    7378
    7479(DEFUN SERVE-SUPDUP (&AUX (CONN (CHAOS:LISTEN "SUPDUP")))
     
    8388                            (SUPDUP-INITIALIZE CONN)
    8489                            (CHAOS:CLOSE CONN))))
    85                 (RETURN-STATE))
     90                ;; (RETURN-STATE)
     91                )
    8692               (T (CHAOS:CLOSE CONN
    8793                               (FORMAT NIL "Connection went into ~S after listening."
     
    101107(DEFUN SUPDUP-INITIALIZE (CONN &AUX CHAOS-STREAM SUPDUP-STREAM W-O)
    102108  (SETQ CHAOS-STREAM (CHAOS:STREAM CONN))
    103   (SEND-GREETING CHAOS-STREAM)
     109  ;; This is apparently a part of the supdup protocol
     110  (FUNCALL CHAOS-STREAM ':STRING-OUT (CHAOS:HOST-DATA CHAOS:MY-ADDRESS))
     111  (FUNCALL CHAOS-STREAM ':TYO 15)
     112  (FUNCALL CHAOS-STREAM ':TYO 12)
     113  (FUNCALL CHAOS-STREAM ':TYO %TDNOP)
     114  (FUNCALL CHAOS-STREAM ':FORCE-OUTPUT)
     115  (SETQ SUPDUP-STREAM (MAKE-SUPDUP-STREAM CHAOS-STREAM))
    104116  (SETQ W-O (FUNCALL SUPDUP-STREAM ':WHICH-OPERATIONS))
    105   (SETQ SUPDUP-STREAM
    106         (MAKE-EDITOR-STREAM (MAKE-SUPDUP-STREAM CHAOS-STREAM)
    107                             ;; Hack Glass ttys here at some point.  RWG has one.
    108                             (COND ((MEMQ ':SET-CURSORPOS W-O) #'DISPLAY-EDITOR)
    109                                   (T #'PRINTING-EDITOR))))
    110   ;; Why this?
     117  (SETQ SUPDUP-STREAM
     118        (SI:MAKE-EDITOR-STREAM SUPDUP-STREAM
     119                               ;; Hack Glass ttys here at some point.  RWG has one.
     120                               (COND ((MEMQ ':SET-CURSORPOS W-O) #'SI:DISPLAY-EDITOR)
     121                                     (T #'SI:PRINTING-EDITOR))))
    111122  (PROCESS-SLEEP 120.)
    112123  (FUNCALL SUPDUP-STREAM ':CLEAR-SCREEN)
     124  (PRINT-LOADED-BAND SUPDUP-STREAM)
     125  (FUNCALL SUPDUP-STREAM ':STRING-OUT (CHAOS:HOST-DATA CHAOS:MY-ADDRESS))
     126  (FUNCALL SUPDUP-STREAM ':TYO #\RETURN)
     127  (FUNCALL SUPDUP-STREAM ':FORCE-OUTPUT)
     128  ;; For debugging
     129  (PUSH SUPDUP-STREAM SUPSER-STREAMS)
     130  (PUSH CURRENT-PROCESS SUPSER-PROCESSES)
    113131  ;; Wake up monitor process
    114   ;; (PUSH CURRENT-PROCESS SUPDUP-PROCESSES)
    115132  ;; (PREPARE-FOR-SUPDUP)
    116133  (SUPDUP-TOP-LEVEL SUPDUP-STREAM))
    117 
    118 (DEFUN SEND-GREETING (STREAM)
    119     (FUNCALL STREAM ':STRING-OUT (CHAOS:HOST-DATA CHAOS:MY-ADDRESS))
    120     (FUNCALL STREAM ':TYO 15)
    121     (FUNCALL STREAM ':TYO 12)
    122     ;; Why this?
    123     (FUNCALL STREAM ':TYO %TDNOP)
    124     (FUNCALL STREAM ':FORCE-OUTPUT))
    125134
    126135;; A copy of SI:LISP-TOP-LEVEL1 which does a :FORCE-OUTPUT before evaluation.
    127136;; Why is this the right place?
    128137;; Note that the stream to use is passed as an argument and bound to the
    129 ;; special variable TERMINAL-IO.  *, +, - are bound so as to be per stack group.
    130 
    131 (DEFUN SUPDUP-TOP-LEVEL (TERMINAL-IO &AUX THROW-FLAG VALUES * + -)
     138;; special variable TERMINAL-IO.  - , +, *, etc. are bound so as to be per stack group.
     139
     140(DEFUN SUPDUP-TOP-LEVEL (TERMINAL-IO &AUX THROW-FLAG - + ++ +++ * ** *** //)
    132141  ;; Do forever
    133142  (DO () (NIL)
     
    139148                     (SETQ - (SI:READ-FOR-TOP-LEVEL))
    140149                     (FUNCALL STANDARD-OUTPUT ':FORCE-OUTPUT)
    141                      (LET ((LISP-TOP-LEVEL-INSIDE-EVAL T))
    142                        (SETQ VALUES (MULTIPLE-VALUE-LIST (EVAL -))))
    143                      ;; Save first value and print all values
    144                      (SETQ * (FIRST VALUE))
    145                      (DOLIST (VALUE VALUES)
     150                     (LET ((SI:LISP-TOP-LEVEL-INSIDE-EVAL T))
     151                       (SETQ // (MULTIPLE-VALUE-LIST (EVAL -))))
     152                     ;; Save first value, list of all values, and previous two values
     153                     (SETQ *** ** ** * * (FIRST //))
     154                     (DOLIST (VALUE //)
    146155                       (TERPRI)
    147156                       (FUNCALL (OR PRIN1 #'PRIN1) VALUE)))))
    148157    ;; Signal return to top level
    149158    (IF THROW-FLAG (PRINT '*))
    150     (SETQ + -)))
     159    (SETQ +++ ++ ++ + + -)))
    151160
    152161(DEFUN 18BIT-IN (STREAM)
     
    175184;; Should precede these variable names with SS- or something.
    176185
    177 (DECLARE (SPECIAL SUPDUP-CHAOS-STREAM MORE-PROCESSING-FLAG
    178                   MORE-PROCESSING-IN-PROGRESS MORE-PROCESSING-LINE
     186(DECLARE (SPECIAL SUPDUP-CHAOS-STREAM SUPDUP-WHICH-OPERATIONS
     187                  MORE-PROCESSING-FLAG MORE-PROCESSING-IN-PROGRESS MORE-PROCESSING-LINE
    179188                  TCTYPE TTYOPT HEIGHT WIDTH TTYROL SMARTS ISPEED OSPEED
    180189                  XPOS YPOS SUPDUP-FINGER-STRING
     
    192201(DEFUN MAKE-SUPDUP-STREAM (SUPDUP-CHAOS-STREAM)
    193202  (MULTIPLE-VALUE-BIND (TCTYPE TTYOPT HEIGHT WIDTH TTYROL SMARTS ISPEED OSPEED)
    194       (RECEIVE-TTY-VARIABLES CH-STREAM)
     203      (RECEIVE-TTY-VARIABLES SUPDUP-CHAOS-STREAM)
    195204    (LET ((SUPDUP-FINGER-STRING)
    196205          (SUPDUP-WHICH-OPERATIONS)
     
    206215      ;; Set the WHICH-OPERATIONS parameter of the supdup stream according
    207216      ;; to the terminal capabilities.
    208       (IF (BIT-MEST %TOMVU TTYOPT)
     217      (IF (BIT-TEST %TOMVU TTYOPT)
    209218          (PUSH-LIST '(:TRIGGER-MORE :READ-CURSORPOS :SET-CURSORPOS
    210219                                     :SET-CURSORPOS-RELATIVE :HOME-CURSOR
     
    223232                        XPOS YPOS MORE-PROCESSING-FLAG MORE-PROCESSING-IN-PROGRESS
    224233                        MORE-PROCESSING-LINE META-BITS-SEEN
    225                         SUPDUP-FINGER-STRING SUPDUP-WHICH-OPERATIONS)
     234                        SUPDUP-CHAOS-STREAM SUPDUP-FINGER-STRING SUPDUP-WHICH-OPERATIONS)
    226235               #'SUPDUP-STREAM))))
    227236
     
    263272  (:READ-CURSORPOS (&OPTIONAL (UNIT ':CHARACTER))
    264273    (SELECTQ UNIT
    265       (:CHARACTER (RETURN XPOS YPOS))
     274      (:CHARACTER (MVRETURN XPOS YPOS))
    266275      (OTHERWISE (FERROR NIL "~S is not a known unit." UNIT))))
    267276  (:SET-CURSORPOS (X Y &OPTIONAL (UNIT ':CHARACTER))
     
    339348;; a process stuffing characters into an IO-BUFFER.
    340349
     350;; User can set this to change control/meta prefixes.
     351
     352(DEFVAR SUPSER-TYI-HOOK 'DEFAULT-SUPSER-TYI-HOOK)
     353
     354(DEFUN DEFAULT-SUPSER-TYI-HOOK (CHAR OP)
     355  (COND ((= CHAR #\BREAK) (BREAK BREAK T) NIL)
     356        ((OR (= CHAR #/Z) (= CHAR #/Z))
     357         (PRINC "Z Quit")
     358         (*THROW 'SI:TOP-LEVEL NIL))
     359        ;; 12-bit keyboard available
     360        ((BIT-TEST %TOFCI TTYOPT) CHAR)
     361        ;; Ascii keyboard.  Accept C-B as break.
     362        ((= CHAR #/B) (BREAK BREAK T) NIL)
     363        ;; C-^ is control prefix, is meta prefix, C-C is control-meta prefix.
     364        ;; Any prefix typed twice transmits the prefix directly.  This doesn't
     365        ;; address the entire character set from Ascii, but its good enough for now.
     366        ((= CHAR #/^)
     367         (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM OP))
     368         (IF (= CHAR #/^) #/^ (DPB 1 %%KBD-CONTROL CHAR)))
     369        ((= CHAR #/)
     370         (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM OP))
     371         (IF (= CHAR #/) #/ (DPB 1 %%KBD-META CHAR)))
     372        ((= CHAR #/C)
     373         (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM OP))
     374         (IF (= CHAR #/C) #/C (DPB 3 %%KBD-CONTROL-META CHAR)))
     375        (T CHAR)))
     376
    341377(DEFUN SUPSER-TYI () (SUPSER-TYI-CHECK-HOOK ':TYI))
    342378(DEFUN SUPSER-TYI-NO-HANG () (SUPSER-TYI-CHECK-HOOK ':TYI-NO-HANG))
     
    362398    (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM OP))
    363399    (COND ((NULL CHAR) (RETURN))
     400          ((
     401 CHAR 300) (SUPDUP-ESCAPE CHAR))
    364402          (( CHAR 34) (RETURN))
    365403          (T (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM ':TYI))
     
    383421        (T (ASCII-TO-LM-CHAR CHAR))))
    384422
    385 ;; User can set this to change control/meta prefixes.
    386 
    387 (DEFVAR SUPSER-TYI-HOOK 'DEFAULT-SUPSER-TYI-HOOK)
    388 
    389 (DEFUN DEFAULT-SUPSER-TYI-HOOK (CHAR OP)
    390   (COND ((NULL
    391         ((= CHAR #\BREAK) (BREAK BREAK T) NIL)
    392         ((OR (= CHAR #/Z) (= CHAR #/Z))
    393          (PRINC "Z Quit")
    394          (*THROW 'SI:TOP-LEVEL NIL))
    395         ;; 12-bit keyboard available
    396         ((BIT-TEST %TOFCI TTYOPT) CHAR)
    397         ;; Ascii keyboard.  Accept C-B as break.
    398         ((= CHAR #/B) (BREAK BREAK T) NIL)
    399         ;; C-^ is control prefix, is meta prefix, C-C is control-meta prefix.
    400         ;; Any prefix typed twice transmits the prefix directly.  This doesn't
    401         ;; address the entire character set from Ascii, but its good enough for now.
    402         ((= CHAR #/^)
    403          (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM OP))
    404          (IF (= CHAR #/^) #/^ (DPB 1 %%KBD-CONTROL CHAR)))
    405         ((= CHAR #/)
    406          (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM OP))
    407          (IF (= CHAR #/) #/ (DPB 1 %%KBD-META CHAR)))
    408         ((= CHAR #/C)
    409          (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM OP))
    410          (IF (= CHAR #/C) #/C (DPB 3 %%KBD-CONTROL-META CHAR)))
    411         (T CHAR)))
    412 
    413423;; Convert C-M to RETURN, C-H to BS, etc. as special cases since it is most likely
    414424;; that the user typed RETURN and BS keys on his keyboard.  Don't convert VT to
     
    445455(DEFUN 12-BIT-TO-LM-CHAR (CHAR &AUX ASC TOP)
    446456  (SETQ TOP (BIT-TEST %TXTOP CHAR))
    447   (SETQ CHAR (LOGAND %TXASC CHAR))
    448   (SETQ CHAR
     457  (SETQ ASC (LOGAND %TXASC CHAR))
     458  (SETQ ASC
    449459        (COND (TOP (COND ((< ASC #\SPACE) ASC)
    450460                         ((= ASC #/A) #\ESC)
     
    598608    (SUPSER-RAW-TYO XPOS))
    599609
     610(DEFUN SUPSER-SET-CURSORPOS-RELATIVE (X Y)
     611  (SUPSER-SET-CURSORPOS (+ XPOS X) (+ YPOS Y)))
     612
    600613;; Use MORE-PROCESSING-IN-PROGRESS flag to avoid recursion.
    601614;; This should be handled higher up.
     
    605618  (SETQ CHAR (SUPSER-RAW-TYI))
    606619  (IF ( CHAR #\SPACE)
    607       (FUNCALL SUPDUP-CHAOS-STRAM ':UNTYI CHAR))
     620      (FUNCALL SUPDUP-CHAOS-STREAM ':UNTYI CHAR))
    608621  ;; Clear out the --More--, home cursor up, and clear the top line.
    609622  (SUPSER-SET-CURSORPOS 0 YPOS)
     
    697710;;; Fancy cpt-monitor display
    698711
     712(declare (special fonts:bigfnt))
     713
    699714(defclass message-window-class window-with-pc-ppr-class (stream))
    700715
  • trunk/lisp/lmio1/tablet.lisp

    r252 r253  
    2929mouse."
    3030  (%UNIBUS-WRITE TABLET-CSR 2)
    31   (PROCESS-WAIT "Tablet"
    32                 #'(LAMBDA (WAIT-FLAG &AUX CSR)
    33                     (SETQ CSR (%UNIBUS-READ TABLET-CSR))
    34                     (SETQ TABLET-BUTTONS (LOGXOR TABLET-MASK
    35                                                  (AR-1 TABLET-MAP-BUTTONS
    36                                                        (LDB %%TABLET-BUTTONS CSR))))
    37                     (COND ((ZEROP (LOGAND CSR %TABLET-BUSY))
    38                            (NOT WAIT-FLAG))
    39                           (( (LOGAND CSR %TABLET-PROXIMITY) 0)
    40                            (SETQ TABLET-PROXIMITY 0)    ;leaving table.
    41                            (NOT WAIT-FLAG))
    42                           (T
    43                             (SETQ TABLET-X (// (* (CAR TABLET-X-SCALE)
    44                                                   (LOGAND 177774 (%UNIBUS-READ TABLET-X-REG)))
    45                                                (CDR TABLET-X-SCALE))
    46                                   TABLET-Y (// (* (CAR TABLET-Y-SCALE)
    47                                                   (LOGAND 177774 (%UNIBUS-READ TABLET-Y-REG)))
    48                                                (CDR TABLET-Y-SCALE)))
    49                             (COND ((ZEROP TABLET-PROXIMITY)
    50                                    (SETQ TABLET-PROXIMITY 1
    51                                          TABLET-OLD-X TABLET-X
    52                                          TABLET-OLD-Y TABLET-Y) ;comming into range
    53                                    (NOT WAIT-FLAG))
    54                                   (T
    55                                     (NOT (AND (= TABLET-X TABLET-OLD-X)
    56                                               (= TABLET-Y TABLET-OLD-Y)
    57                                               (= TABLET-OLD-BUTTONS TABLET-BUTTONS)
    58                                               WAIT-FLAG)))))))
    59                 WAIT-FLAG)
     31  (COND (WAIT-FLAG
     32          (PROCESS-WAIT "Tablet"
     33                        #'(LAMBDA ()
     34                            (TABLET-UPDATE)
     35                            (NOT (AND (= TABLET-X TABLET-OLD-X)
     36                                      (= TABLET-Y TABLET-OLD-Y)
     37                                      (= TABLET-OLD-BUTTONS TABLET-BUTTONS)))))))
    6038  (WITHOUT-INTERRUPTS
     39    (COND ((NULL WAIT-FLAG) (TABLET-UPDATE)))
    6140    (SETQ CHANGED-BUTTONS (LOGXOR TABLET-BUTTONS TABLET-OLD-BUTTONS)
    6241          TABLET-OLD-BUTTONS TABLET-BUTTONS
     
    7049          (BOOLE 2 TABLET-BUTTONS CHANGED-BUTTONS)))
    7150
     51
     52(DEFUN TABLET-UPDATE (&AUX CSR)
     53  (SETQ CSR (%UNIBUS-READ TABLET-CSR))
     54  (SETQ TABLET-BUTTONS (LOGXOR TABLET-MASK
     55                               (AR-1 TABLET-MAP-BUTTONS
     56                                     (LDB %%TABLET-BUTTONS CSR))))
     57  (COND ;((ZEROP (LOGAND CSR %TABLET-BUSY)))  ;gobble most recent data
     58        (( (LOGAND CSR %TABLET-PROXIMITY) 0)
     59         (SETQ TABLET-PROXIMITY 0))     ;leaving table.
     60        (T
     61          (SETQ TABLET-X (// (* (CAR TABLET-X-SCALE)
     62                                (LOGAND 177774 (%UNIBUS-READ TABLET-X-REG)))
     63                             (CDR TABLET-X-SCALE))
     64                TABLET-Y (// (* (CAR TABLET-Y-SCALE)
     65                                (LOGAND 177774 (%UNIBUS-READ TABLET-Y-REG)))
     66                             (CDR TABLET-Y-SCALE)))
     67          (COND ((ZEROP TABLET-PROXIMITY)
     68                 (SETQ TABLET-PROXIMITY 1
     69                       TABLET-OLD-X TABLET-X
     70                       TABLET-OLD-Y TABLET-Y))) ;comming into range
     71          )))
    7272
    7373(DEFUN INSTALL-TABLET (&OPTIONAL (INSTALL-P T))
  • trunk/lisp/lmio1/time.lisp

    r252 r253  
    115115          (LET ((B (\ (+ YEAR 1899.) 400.)))
    116116            (\ (- (+ (1+ B) (SETQ B (// B 4))) (// B 25.)) 7)))
    117         (FEB29 (IF (ZEROP (\ YEAR 4)) 1 0)))    ;Good enough for this century, and the next
     117        (FEB29 (IF (LEAP-YEAR-P YEAR) 1 0)))
    118118    (LET ((DOW-APRIL-30 (\ (+ DOW-BEG-YEAR 119. FEB29) 7)))
    119119      (- 30. DOW-APRIL-30))))
     
    127127  (SETQ TEM (+ (1- DAY) (AREF *CUMULATIVE-MONTH-DAYS-TABLE* MONTH)
    128128               (// (1- YEAR) 4) (* YEAR 365.))) ;Number of days since 1/1/00.
    129   (AND (> MONTH 2) (ZEROP (\ YEAR 4))
     129  (AND (> MONTH 2) (LEAP-YEAR-P YEAR)
    130130       (SETQ TEM (1+ TEM)))                     ;After 29-Feb in a leap year.
    131131  (+ SECONDS (* TEM 86400.) (* TIMEZONE 3600.)))        ;Return number of seconds.
     
    179179                         (SETQ *LAST-TIME-MINUTES* (\ *LAST-TIME-MINUTES* 60.)))
    180180                  24.)
    181                (< (PROG1 (SETQ *LAST-TIME-DAY* (1+ *LAST-TIME-DAY*))
     181               (
     182 (PROG1 (SETQ *LAST-TIME-DAY* (1+ *LAST-TIME-DAY*))
    182183                         (SETQ *LAST-TIME-DAY-OF-THE-WEEK*
    183184                               (\ (1+ *LAST-TIME-DAY-OF-THE-WEEK*) 7))
    184185                         (SETQ *LAST-TIME-HOURS* 0))
    185186                  (MONTH-LENGTH *LAST-TIME-MONTH* *LAST-TIME-YEAR*))
    186                (< (SETQ *LAST-TIME-DAY* 1
     187               (
     188 (SETQ *LAST-TIME-DAY* 1
    187189                        *LAST-TIME-MONTH* (1+ *LAST-TIME-MONTH*))
    188190                  12.)
     
    200202(DEFUN MONTH-LENGTH (MONTH YEAR)
    201203  (IF (= MONTH 2)
    202       (IF (ZEROP (\ YEAR 4)) 29. 28.)
     204      (IF (LEAP-YEAR-P YEAR) 29. 28.)
    203205      (NTH MONTH *MONTH-LENGTHS*)))
     206
     207(DEFUN LEAP-YEAR-P (YEAR)
     208  (AND (ZEROP (\ YEAR 4))
     209       (OR (NOT (ZEROP (\ YEAR 100.)))
     210           (ZEROP (\ YEAR 400.)))))
    204211
    205212(DEFUN DAYLIGHT-SAVINGS-P ()
     
    475482                 (SETQ MONTH (// TOKEN 100.)
    476483                       DAY (\ TOKEN 100.))
    477                  (COND ((
    478  DAY 12.))
    479                        ((OR (
    480  MONTH 12.) AMBIGUOUS-ASSUME-DAY-FIRST)
     484                 (COND ((> DAY 12.))
     485                       ((OR (> MONTH 12.) AMBIGUOUS-ASSUME-DAY-FIRST)
    481486                        (PSETQ DAY MONTH MONTH DAY)))
    482487                 (SETQ STATE (IF YEAR ':DONE ':DAY-AND-MONTH-SEEN)))
    483488                (T
    484                  (IF (
    485  TOKEN 12.)
     489                 (IF (> TOKEN 12.)
    486490                     (SETQ DAY TOKEN)
    487491                     (SETQ MONTH TOKEN))
  • trunk/lisp/lmio1/versat.lisp

    r252 r253  
    8888        (DOTIMES (Y H)
    8989          (LET ((BIT (AREF INPUT-ARRAY (- W X 1) Y)))
    90             (ASET BIT LINE-ARRAY (LOGXOR (* 2 Y) 7))
    91             (ASET BIT LINE-ARRAY (LOGXOR (1+ (* 2 Y)) 7))))
     90            (ASET BIT LINE-ARRAY (* 2 Y))
     91            (ASET BIT LINE-ARRAY (1+ (* 2 Y)))))
    9292        ;; Now have line in line buffer, print it twice
    9393        (VERSATEC-WAIT)
     
    129129                (XPOS (+ MARGIN (* SCALE X))))
    130130            (DOTIMES (I SCALE)
    131               (ASET BIT LINE-ARRAY (LOGXOR (+ I XPOS) 7)))))
     131              (ASET BIT LINE-ARRAY (+ I XPOS)))))
    132132        ;; Now have line in line buffer, print it twice
    133133        (DOTIMES (I SCALE)
  • trunk/lisp/lmio1/votrax.lisp

    r252 r253  
    11;;;-*-LISP-*-
    22
     3(comment
    34(DECLARE (SPECIAL DL11-RCV-CSR DL11-RCV-DAT DL11-XMT-CSR DL11-XMT-DAT))
    45(SETQ DL11-RCV-CSR 775630)
     
    2021      ((
    2122 I LEN))
    22     (DL11-TYO (AR-1 STR I))))
     23    (DL11-TYO (AR-1 STR I))))  )
     24
     25(declare (special votrax-stream))
     26
     27(setq votrax-stream (si:make-serial-stream))
     28
    2329
    2430(DECLARE (SPECIAL PHONEME-ALIST LAST-UTTERANCE))
     
    6874       (INT 300)
    6975       (PH))
    70       ((NULL LIST) (DL11-TYO -1) T)
     76      ((NULL LIST) (funcall votrax-stream ':TYO -1) T)
    7177    (SETQ PH (CAR LIST))
    7278    (COND ((NUMBERP PH)
    7379           (SETQ INT (- 400 (* PH 100))))
    7480          (T
    75            (DL11-TYO (+ INT (CDR (ASSQ PH PHONEME-ALIST))))))))
     81           (funcall votrax-stream ':tyo (+ INT (CDR (ASSQ PH PHONEME-ALIST))))))))
    7682
    7783(DEFUN SPEAK (&OPTIONAL (X LAST-UTTERANCE))
     
    120126(DEFUN SPEAK-RAN (N)
    121127  (DOTIMES (I N)
    122     (DL11-TYO (RANDOM 400)))
    123   (DL11-TYO -1))
     128    (funcall votrax-stream ':TYO (RANDOM 400)))
     129  (funcall votrax-stream ':TYO -1))
    124130
    125131(DEFUN OPERATOR ()
  • trunk/lisp/lmio1/xfed.lisp

    r252 r253  
    1 ;;; -*-LISP-*-
     1;;; -*-Mode:LISP;Package:FED-*-
    22
    33(SPECIAL FED-WINDOW FED-FD-ALIST FED-WINDOW-CLASS)
  • trunk/lisp/lmio1/xgp.lisp

    r252 r253  
    6161   (let ((inhibit-scheduling-flag t)
    6262         (hcarray (allocate-resource 'xgp-hardcopy-bit-array)))
     63     (tv:who-line-update)
    6364     (copy-array-contents array hcarray)
    6465     (process-run-function "XGP Hardcopy"
Note: See TracChangeset for help on using the changeset viewer.