Changeset 253

Show
Ignore:
Timestamp:
08/18/11 08:08:01 (22 months ago)
Author:
rjs
Message:

Update.

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

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 
    … …  
    473475(DEFVAR LG684-JACK-YOFFS NIL) 
    474476 
     477(DEFVAR DEC-EDGE-XOFFS NIL)    ;offset within dec edge connector.  
    475478 
    476479(DEFUN LG684-PRNLOC (LOC &AUX ANS) 
    … …  
    499502  ANS) 
    500503 
    501 (DEFUN LG684-INIT (&AUX JN DX) 
     504(DEFUN LG684-INIT (&AUX JN DX PN) 
    502505  (SETQ LG684-JACKSZ (MAKE-ARRAY NIL ART-Q 13.))        ;J0 illegal 
    503506  (DOTIMES (C 12.) 
    … …  
    523526  (SETQ LG684-PADDLE-XOFFS (MAKE-ARRAY NIL ART-Q 6) 
    524527        LG684-PADDLE-YOFFS (MAKE-ARRAY NIL ART-Q 6)) 
    525   (SETQ JN 0 
     528  (SETQ JN 5 
    526529        DX 0)   
    527530  (DOTIMES (JGROUP 3) 
    528531    (AS-1 DX LG684-PADDLE-XOFFS JN) 
    529532    (AS-1 LG684-DECCNY LG684-PADDLE-YOFFS JN) 
    530     (SETQ JN (1+ JN) 
     533    (SETQ JN (1- JN) 
    531534          DX (+ DX LG684-DECX1)) 
    532535    (AS-1 DX LG684-PADDLE-XOFFS JN) 
    533536    (AS-1 LG684-DECCNY LG684-PADDLE-YOFFS JN) 
    534     (SETQ JN (1+ JN) 
    535           DX (+ DX LG684-DECX2)))) 
     537    (SETQ JN (1- JN) 
     538          DX (+ DX LG684-DECX2))) 
     539  (SETQ DEC-EDGE-XOFFS (MAKE-ARRAY NIL ART-Q 18.)) 
     540  (SETQ DX 0 
     541        PN 17.) 
     542  (DOTIMES (PGROUP 3) 
     543    (AS-1 DX DEC-EDGE-XOFFS PN) 
     544    (SETQ PN (1- PN)) 
     545    (DOTIMES (C 5) 
     546      (SETQ DX (+ DX LG684-DCPNSP)) 
     547      (AS-1 DX DEC-EDGE-XOFFS PN) 
     548      (SETQ PN (1- PN))) 
     549    (SETQ DX (+ DX LG684-DCGRSP)))) 
    536550 
    537551(DEFUN LG684-GETLOC (STR BEG LIM &AUX C VAL-LIST IDX) 
    … …  
    565579    (5 (SI:DESTRUCTURING-BIND (LET PADDLE-LET PADDLE-SIDE) VAL-LIST 
    566580                              (DPB LET LG684-%CONN 
    567                                    (DPB (+ (LSH (CTEST-DEC-LETTER-TO-NUMBER PADDLE-LET) 1) 
     581                                   (DPB (+ (LSH PADDLE-LET 1)  ;already dec-letter hacked 
    568582                                           (1- PADDLE-SIDE)) 
    569583                                        CTEST-%%PIN 
    … …  
    596610                   (FERROR NIL "bad conn number")) 
    597611               (SETQ X (+ X (AR-1 LG684-PADDLE-XOFFS (1- CONN)) 
    598                           (* LG684-DCPNSP (LSH PIN -1))) 
     612                          (AR-1 DEC-EDGE-XOFFS (1- (LSH PIN -1)))) 
    599613                     Y (+ Y (AR-1 LG684-PADDLE-YOFFS (1- CONN)) 
    600614                          (* LG684-DCPINO (LOGAND PIN 1))))) 
    … …  
    606620                              (AR-1 LG684-JACK-YOFFS CONN))) 
    607621                   ))) 
    608         (return x y))) 
     622        (return (- 9000 x) (- 17000 y) 
     623)))  ;board fits in tester backwards .. 
    609624 
    610625 
    … …  
    617632 
    618633(DEFUN CTEST-DEC-LETTER-TO-NUMBER (NUM) 
     634  (SETQ NUM (+ NUM #/@)) 
    619635  (COND ((MEMQ NUM '(#/G #/I #/O #/Q)) 
    620636         (FERROR NIL "~C invalid DEC letter" NUM))) 
    … …  
    623639  (IF (> NUM #/I) (SETQ NUM (1- NUM))) 
    624640  (IF (> NUM #/G) (SETQ NUM (1- NUM))) 
     641  (SETQ NUM (- NUM #/@)) 
    625642  NUM) 
    626643 

  • trunk/lisp/lmio1/dplt.lisp

    r252 r253  
    7676                   (:COPIES (SETQ COPIES (CADR L))) 
    7777                   (:FILE  (SETQ SPOOL-FILENAME 
    78                                  (SI:FILE-MERGE-PATHNAMES (CADR L) SPOOL-FILENAME))) 
     78                                 (AND (CADR L) 
     79                                      (SI:FILE-MERGE-PATHNAMES (CADR L) SPOOL-FILENAME)))) 
    7980                   (:BLANK-PAGE (SETQ BLANK-PAGE T)) 
    8081                   (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  
    138138                            'FULL-SCREEN)) 
    139139  (FORMAT STREAM "Documentation of ESC keys:~%") 
    140   (DOLIST (ITEM (REVERSE KBD-ESC-REPOSITORY)) 
     140  (SETQ KBD-ESC-REPOSITORY (SORTCAR KBD-ESC-REPOSITORY #'CHAR-LESSP)) 
     141  (DOLIST (ITEM KBD-ESC-REPOSITORY) 
    141142    (KBD-ESC-PRINT-DOCUMENTATION STREAM ITEM)) 
    142143  (FORMAT STREAM "~2%Type a space to flush:") 

  • trunk/lisp/lmio1/fed.lisp

    r252 r253  
    577577                                            FD-SPACE-WIDTH 7)) 
    578578             (AS-1 (MAKE-CHAR-DESCRIPTOR 
    579                     MAKE-ARRAY (DEFAULT-ARRAY-AREA ART-4B '(11 7)) 
     579                    MAKE-ARRAY (NIL ART-4B '(11 7)) 
    580580                    CD-CHAR-WIDTH 7 
    581581                    CD-CHAR-LEFT-KERN 0) 
    … …  
    857857    ;; Copy the data in the FED buffer into a CD 
    858858    (SETQ CD (MAKE-CHAR-DESCRIPTOR 
    859                       MAKE-ARRAY (DEFAULT-ARRAY-AREA ART-4B (LIST YWIDTH XWIDTH)) 
     859                      MAKE-ARRAY (NIL ART-4B (LIST YWIDTH XWIDTH)) 
    860860                      CD-CHAR-WIDTH (- CHAR-BOX-X2 CHAR-BOX-X1) 
    861861                      CD-CHAR-LEFT-KERN KERN)) 

  • trunk/lisp/lmio1/fntcnv.lisp

    r252 r253  
    346346  (or fontname (setq fontname (funcall filename ':name))) 
    347347  (and (stringp fontname) (setq fontname (intern fontname "FONTS"))) 
    348   (setq stream (open fielname '(:fixnum :in :byte-size 9.))) 
     348  (setq stream (open filename '(:fixnum :in :byte-size 9.))) 
    349349  (setq fd (make-font-descriptor fd-name fontname)) 
    350350  ;; 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  
    589589 X X1) STOP)) 
    590590                ;; If Y would be below the line, use CH1 else use CH2 
    591                 (IF (< (// (SMALL-FLOAT (+ Y CDY2)) (+ X CDX2)) SLOPE) 
     591                (IF (< (// (SMALL-FLOAT (- (+ Y CDY2) Y0)) (- (+ X CDX2) X0)) SLOPE) 
    592592                    (SETQ CH CH1 XINC CDX1 YINC CDY1) 
    593593                    (SETQ CH CH2 XINC CDX2 YINC CDY2)) 

  • trunk/lisp/lmio1/reldmp.lisp

    r252 r253  
    250250    (let ((total-len (%structure-total-size object)) 
    251251          (boxed-len (%structure-boxed-size object)) 
    252           (start-offset (cond ((and (arrayp object) 
    253                                     (array-has-leader-p object)) 
    254                                (- (+ 2 (array-leader-length object)))) 
    255                               (t 0)))) 
     252          (start-offset (%pointer-difference (%find-structure-leader object) 
     253                                             object))) 
    256254      (let ((index (allocate-section-space secnum total-len)) 
    257255            (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. 
    … …  
    8888 
    8989;Then comes a halfword containing the number FASL-OP-REL-FILE. 
    90 ;This tells FASLOAD to call FASL-REL-FILE. 
     90;This tells FASLOAD to call FASL-OP-REL-FILE which calls this loader. 
    9191 
    9292;Then comes a halfword containing the op-code READ-STORAGE-FORMAT-VERSION 
    … …  
    110110 
    111111;Then comes a halfword containing zero. 
     112;This causes this loader to exit. 
     113;Then comes a halfword containing FASL-OP-END-OF-FILE, 
     114;or more qfasl format data. 
    112115 
    113116;What are sections? 
    … …  
    142145;Load a relocatable file from the stream LOAD-STREAM. 
    143146;PKG-SPECIFIED is the package argument to FASLOAD, or NIL. 
    144 ;The other args are the data for bypassing the stream 
     147;The other three args are the data for bypassing the stream 
    145148;and reading directly out of the chaosnet buffer. 
    146149;They are passed along because FASLOAD already started using them. 
     150;We return the same three quantities, as updated, so FASLOAD can continue. 
    147151;See READ-HALFWORD for more information. 
    148152(defun rel-load-stream (load-stream 
    … …  
    163167          (aset (symeval (car l)) area-vector i)) 
    164168        (init-data-type-tables) 
    165         (top-level))) 
     169        (top-level) 
     170        (return stream-array stream-index stream-count))) 
    166171 
    167172(defun init-data-type-tables () 
    168   (setq data-type-pointer-p (make-array temp-area art-q 
     173  (setq data-type-pointer-p (make-array working-storage-area art-q 
    169174                                        (lsh 1 (logand %%q-data-type 77)))) 
    170175  (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) 
    … …  
    174183;; Should precede these variable names with SS- or something. 
    175184 
    176 (DECLARE (SPECIAL SUPDUP-CHAOS-STREAM MORE-PROCESSING-FLAG 
    177                   MORE-PROCESSING-IN-PROGRESS MORE-PROCESSING-LINE 
     185(DECLARE (SPECIAL SUPDUP-CHAOS-STREAM SUPDUP-WHICH-OPERATIONS 
     186                  MORE-PROCESSING-FLAG MORE-PROCESSING-IN-PROGRESS MORE-PROCESSING-LINE 
    178187                  TCTYPE TTYOPT HEIGHT WIDTH TTYROL SMARTS ISPEED OSPEED 
    179188                  XPOS YPOS SUPDUP-FINGER-STRING 
    … …  
    191200(DEFUN MAKE-SUPDUP-STREAM (SUPDUP-CHAOS-STREAM) 
    192201  (MULTIPLE-VALUE-BIND (TCTYPE TTYOPT HEIGHT WIDTH TTYROL SMARTS ISPEED OSPEED) 
    193       (RECEIVE-TTY-VARIABLES CH-STREAM) 
     202      (RECEIVE-TTY-VARIABLES SUPDUP-CHAOS-STREAM) 
    194203    (LET ((SUPDUP-FINGER-STRING) 
    195204          (SUPDUP-WHICH-OPERATIONS) 
    … …  
    205214      ;; Set the WHICH-OPERATIONS parameter of the supdup stream according 
    206215      ;; to the terminal capabilities. 
    207       (IF (BIT-MEST %TOMVU TTYOPT) 
     216      (IF (BIT-TEST %TOMVU TTYOPT) 
    208217          (PUSH-LIST '(:TRIGGER-MORE :READ-CURSORPOS :SET-CURSORPOS 
    209218                                     :SET-CURSORPOS-RELATIVE :HOME-CURSOR 
    … …  
    222231                        XPOS YPOS MORE-PROCESSING-FLAG MORE-PROCESSING-IN-PROGRESS 
    223232                        MORE-PROCESSING-LINE META-BITS-SEEN 
    224                         SUPDUP-FINGER-STRING SUPDUP-WHICH-OPERATIONS) 
     233                        SUPDUP-CHAOS-STREAM SUPDUP-FINGER-STRING SUPDUP-WHICH-OPERATIONS) 
    225234               #'SUPDUP-STREAM)))) 
    226235 
    … …  
    262271  (:READ-CURSORPOS (&OPTIONAL (UNIT ':CHARACTER)) 
    263272    (SELECTQ UNIT 
    264       (:CHARACTER (RETURN XPOS YPOS)) 
     273      (:CHARACTER (MVRETURN XPOS YPOS)) 
    265274      (OTHERWISE (FERROR NIL "~S is not a known unit." UNIT)))) 
    266275  (:SET-CURSORPOS (X Y &OPTIONAL (UNIT ':CHARACTER)) 
    … …  
    337346;; a process stuffing characters into an IO-BUFFER. 
    338347 
     348;; User can set this to change control/meta prefixes. 
     349 
     350(DEFVAR SUPSER-TYI-HOOK 'DEFAULT-SUPSER-TYI-HOOK) 
     351 
     352(DEFUN DEFAULT-SUPSER-TYI-HOOK (CHAR OP) 
     353  (COND ((= CHAR #\BREAK) (BREAK BREAK T) NIL) 
     354        ((OR (= CHAR #/Z) (= CHAR #/Z)) 
     355         (PRINC "Z Quit") 
     356         (*THROW 'SI:TOP-LEVEL NIL)) 
     357        ;; 12-bit keyboard available 
     358        ((BIT-TEST %TOFCI TTYOPT) CHAR) 
     359        ;; Ascii keyboard.  Accept C-B as break. 
     360        ((= CHAR #/B) (BREAK BREAK T) NIL) 
     361        ;; C-^ is control prefix, is meta prefix, C-C is control-meta prefix. 
     362        ;; Any prefix typed twice transmits the prefix directly.  This doesn't 
     363        ;; address the entire character set from Ascii, but its good enough for now. 
     364        ((= CHAR #/^) 
     365         (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM OP)) 
     366         (IF (= CHAR #/^) #/^ (DPB 1 %%KBD-CONTROL CHAR))) 
     367        ((= CHAR #/) 
     368         (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM OP)) 
     369         (IF (= CHAR #/) #/ (DPB 1 %%KBD-META CHAR))) 
     370        ((= CHAR #/C) 
     371         (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM OP)) 
     372         (IF (= CHAR #/C) #/C (DPB 3 %%KBD-CONTROL-META CHAR))) 
     373        (T CHAR))) 
     374 
    339375(DEFUN SUPSER-TYI () (SUPSER-TYI-CHECK-HOOK ':TYI)) 
    340376(DEFUN SUPSER-TYI-NO-HANG () (SUPSER-TYI-CHECK-HOOK ':TYI-NO-HANG)) 
    … …  
    360396    (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM OP)) 
    361397    (COND ((NULL CHAR) (RETURN)) 
     398          (( 
     399 CHAR 300) (SUPDUP-ESCAPE CHAR))  
    362400          (( CHAR 34) (RETURN)) 
    363401          (T (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM ':TYI)) 
    … …  
    381419        (T (ASCII-TO-LM-CHAR CHAR)))) 
    382420 
    383 ;; User can set this to change control/meta prefixes. 
    384  
    385 (DEFVAR SUPSER-TYI-HOOK 'DEFAULT-SUPSER-TYI-HOOK) 
    386  
    387 (DEFUN DEFAULT-SUPSER-TYI-HOOK (CHAR OP) 
    388   (COND ((NULL 
    389         ((= CHAR #\BREAK) (BREAK BREAK T) NIL) 
    390         ((OR (= CHAR #/Z) (= CHAR #/Z)) 
    391          (PRINC "Z Quit") 
    392          (*THROW 'SI:TOP-LEVEL NIL)) 
    393         ;; 12-bit keyboard available 
    394         ((BIT-TEST %TOFCI TTYOPT) CHAR) 
    395         ;; Ascii keyboard.  Accept C-B as break. 
    396         ((= CHAR #/B) (BREAK BREAK T) NIL) 
    397         ;; C-^ is control prefix, is meta prefix, C-C is control-meta prefix. 
    398         ;; Any prefix typed twice transmits the prefix directly.  This doesn't 
    399         ;; address the entire character set from Ascii, but its good enough for now. 
    400         ((= CHAR #/^) 
    401          (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM OP)) 
    402          (IF (= CHAR #/^) #/^ (DPB 1 %%KBD-CONTROL CHAR))) 
    403         ((= CHAR #/) 
    404          (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM OP)) 
    405          (IF (= CHAR #/) #/ (DPB 1 %%KBD-META CHAR))) 
    406         ((= CHAR #/C) 
    407          (SETQ CHAR (FUNCALL SUPDUP-CHAOS-STREAM OP)) 
    408          (IF (= CHAR #/C) #/C (DPB 3 %%KBD-CONTROL-META CHAR))) 
    409         (T CHAR))) 
    410  
    411421;; Convert C-M to RETURN, C-H to BS, etc. as special cases since it is most likely 
    412422;; that the user typed RETURN and BS keys on his keyboard.  Don't convert VT to 
    … …  
    443453(DEFUN 12-BIT-TO-LM-CHAR (CHAR &AUX ASC TOP) 
    444454  (SETQ TOP (BIT-TEST %TXTOP CHAR)) 
    445   (SETQ CHAR (LOGAND %TXASC CHAR)) 
    446   (SETQ CHAR 
     455  (SETQ ASC (LOGAND %TXASC CHAR)) 
     456  (SETQ ASC 
    447457        (COND (TOP (COND ((< ASC #\SPACE) ASC) 
    448458                         ((= ASC #/A) #\ESC) 
    … …  
    595605    (SUPSER-RAW-TYO XPOS)) 
    596606 
     607(DEFUN SUPSER-SET-CURSORPOS-RELATIVE (X Y) 
     608  (SUPSER-SET-CURSORPOS (+ XPOS X) (+ YPOS Y))) 
     609 
    597610;; Use MORE-PROCESSING-IN-PROGRESS flag to avoid recursion. 
    598611;; This should be handled higher up. 
    … …  
    602615  (SETQ CHAR (SUPSER-RAW-TYI)) 
    603616  (IF ( CHAR #\SPACE) 
    604       (FUNCALL SUPDUP-CHAOS-STRAM ':UNTYI CHAR)) 
     617      (FUNCALL SUPDUP-CHAOS-STREAM ':UNTYI CHAR)) 
    605618  ;; Clear out the --More--, home cursor up, and clear the top line. 
    606619  (SUPSER-SET-CURSORPOS 0 YPOS) 
    … …  
    692705;;; Fancy cpt-monitor display 
    693706 
     707(declare (special fonts:bigfnt)) 
     708 
    694709(defclass message-window-class window-with-pc-ppr-class (stream)) 
    695710 

  • 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. 
    … …  
    178178                         (SETQ *LAST-TIME-MINUTES* (\ *LAST-TIME-MINUTES* 60.))) 
    179179                  24.) 
    180                (< (PROG1 (SETQ *LAST-TIME-DAY* (1+ *LAST-TIME-DAY*)) 
     180               ( 
     181 (PROG1 (SETQ *LAST-TIME-DAY* (1+ *LAST-TIME-DAY*)) 
    181182                         (SETQ *LAST-TIME-DAY-OF-THE-WEEK* 
    182183                               (\ (1+ *LAST-TIME-DAY-OF-THE-WEEK*) 7)) 
    183184                         (SETQ *LAST-TIME-HOURS* 0)) 
    184185                  (MONTH-LENGTH *LAST-TIME-MONTH* *LAST-TIME-YEAR*)) 
    185                (< (SETQ *LAST-TIME-DAY* 1 
     186               ( 
     187 (SETQ *LAST-TIME-DAY* 1 
    186188                        *LAST-TIME-MONTH* (1+ *LAST-TIME-MONTH*)) 
    187189                  12.) 
    … …  
    199201(DEFUN MONTH-LENGTH (MONTH YEAR) 
    200202  (IF (= MONTH 2) 
    201       (IF (ZEROP (\ YEAR 4)) 29. 28.) 
     203      (IF (LEAP-YEAR-P YEAR) 29. 28.) 
    202204      (NTH MONTH *MONTH-LENGTHS*))) 
     205 
     206(DEFUN LEAP-YEAR-P (YEAR) 
     207  (AND (ZEROP (\ YEAR 4)) 
     208       (OR (NOT (ZEROP (\ YEAR 100.))) 
     209           (ZEROP (\ YEAR 400.))))) 
    203210 
    204211(DEFUN DAYLIGHT-SAVINGS-P () 
    … …  
    471478                 (SETQ MONTH (// TOKEN 100.) 
    472479                       DAY (\ TOKEN 100.)) 
    473                  (COND (( 
    474  DAY 12.)) 
    475                        ((OR ( 
    476  MONTH 12.) AMBIGUOUS-ASSUME-DAY-FIRST) 
     480                 (COND ((> DAY 12.)) 
     481                       ((OR (> MONTH 12.) AMBIGUOUS-ASSUME-DAY-FIRST) 
    477482                        (PSETQ DAY MONTH MONTH DAY))) 
    478483                 (SETQ STATE (IF YEAR ':DONE ':DAY-AND-MONTH-SEEN))) 
    479484                (T 
    480                  (IF ( 
    481  TOKEN 12.) 
     485                 (IF (> TOKEN 12.) 
    482486                     (SETQ DAY TOKEN) 
    483487                     (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"