source: trunk/lisp/lmcons/ccgsyl.lisp @ 215

Last change on this file since 215 was 215, checked in by rjs, 7 years ago

Update.

File size: 3.7 KB
Line 
1;-*- LISP -*-
2;       ** (c) Copyright 1980 Massachusetts Institute of Technology **
3(DECLARE (COND ((STATUS FEATURE LISPM))   ;DO NOTHING ON LISP MACHINE.
4               ((NULL (MEMQ 'NEWIO (STATUS FEATURES)))
5                (BREAK 'YOU-HAVE-TO-COMPILE-THIS-WITH-QCOMPL T))
6               ((NULL (GET 'IF-FOR-MACLISP 'MACRO))
7                (LOAD '(MACROS > DSK LISPM2))
8                (LOAD '(DEFMAC FASL DSK LISPM2))
9                (LOAD '(LMMAC > DSK LISPM2))
10                (MACROS T))))   ;SEND OVER THE REST OF THE MACROS IN THIS FILE
11
12(IF-FOR-LISPM
13(DEFUN USER:CC ()
14   (LET ((PACKAGE (PKG-FIND-PACKAGE 'CADR)))
15      (CADR:CC))))
16
17(DECLARE (SPECIAL CC-GETSYL-UNRCH CC-GETSYL-UNRCH-TOKEN CC-LOW-LEVEL-FLAG))
18(DECLARE (FIXNUM CH))
19(DECLARE (EXPR-HASH T))
20(SETQ DEFUN T)
21
22(SETQ CC-GETSYL-UNRCH NIL)
23(SETQ CC-GETSYL-UNRCH-TOKEN NIL)
24(DECLARE (SPECIAL OLD-STREAM CC-INPUT-STREAM CC-OUTPUT-STREAM))
25
26(DEFUN CC-GETSYL-RCH NIL
27 (PROG (CH)
28        (COND (CC-GETSYL-UNRCH
29                (SETQ CH CC-GETSYL-UNRCH)
30                (SETQ CC-GETSYL-UNRCH NIL))
31              (T (COND (CC-LOW-LEVEL-FLAG (CC-REPLACE-STATE)))
32                 (SETQ CH (TYI CC-INPUT-STREAM '3))))
33     X  (RETURN CH)))
34
35(DEFUN CC-GETSYL-READ-TOKEN NIL
36  (PROG (TOK CH TERM-TOKEN)
37        (COND (CC-GETSYL-UNRCH-TOKEN
38                (SETQ TOK CC-GETSYL-UNRCH-TOKEN)
39                (SETQ CC-GETSYL-UNRCH-TOKEN NIL)
40                (RETURN TOK)))
41   L    (SETQ CH (CC-GETSYL-RCH))
42        (COND ((= CH 3)
43                (SETQ TERM-TOKEN '*EOF*)
44                (GO X))                 ;EOF
45              ((= CH 177)
46                (OR TOK (RETURN '*RUB*)) ;OVER-RUBOUT
47                (SETQ TOK (CDR TOK))
48                (CURSORPOS 'X)
49                (GO L))
50              ((OR (AND (< 100 CH)
51                        (< CH 133))
52                   (AND (< 57 CH)
53                        (< CH 72))
54                   (= CH 56))
55               (GO ALPHA-NUM))
56              ((AND (< 140 CH) (< CH 173))
57               (SETQ CH (- CH 40))
58               (GO ALPHA-NUM))
59              ((= CH 55)                ;-
60                (GO ALPHA-NUM))
61;             ((OR (= CH 40)
62;                  (= CH 15)
63;                  (= CH 12)
64;                  (= CH 11)
65;                  (= CH 14))
66;               (GO SEP))
67              ((= CH 73)
68                (GO SEMI)))
69;DROP THRU ON "SCO"
70        (SETQ TERM-TOKEN (ASCII CH))
71  SEP
72  X     (COND (TOK
73               (SETQ TOK (NREVERSE TOK))
74               (SETQ TOK
75                     (COND ((DO L TOK (CDR L) (NULL L)
76                              (OR (AND (< 57 (CAR L)) (< (CAR L) 72))
77                                  (= (CAR L) 55)
78                                  (= (CAR L) 53)
79                                  (RETURN T)))
80                            (IMPLODE TOK))      ;HAS LETTERS OR DOTS IN IT
81                           (T (READLIST TOK)))) ;A NUMBER (DIGITS, PLUS, MINUS)
82                (SETQ CC-GETSYL-UNRCH-TOKEN TERM-TOKEN)
83                (RETURN TOK))
84              (TERM-TOKEN
85                (RETURN TERM-TOKEN))
86              (T (GO L)))
87  SEMI  (COND ((= (CC-GETSYL-RCH) 15)
88                (SETQ CC-GETSYL-UNRCH 15)
89                (GO L)))
90        (GO SEMI)
91  ALPHA-NUM
92        (SETQ TOK (CONS CH TOK))
93        (GO L)))
94
95(IF-FOR-LISPM
96(DEFUN CC-STREAM (OP &REST ARGS)
97  (SELECTQ OP
98           (:TYI (LET ((CHAR (FUNCALL STANDARD-INPUT ':TYI)))
99                      (COND ((AND (ZEROP (LDB %%KBD-CONTROL-META CHAR))
100                                  (< CHAR 200)) ;Printing
101                             CHAR)
102                            ((OR (= CHAR #/L) (= CHAR #/l) (= CHAR #\FORM))
103                             (FUNCALL STANDARD-INPUT ':CLEAR-SCREEN)
104                             14)
105                            ((= CHAR #\RUBOUT) 177) ;Map rubout
106                            (T (LOGAND CHAR 37))))) ;Map CR, LF, etc.
107           (:TYO (LET ((CHAR (CAR ARGS)))
108                   (COND ((= CHAR 177) )
109                         ;; Ascii printing and new-type format effectors go through
110                         ((>= CHAR 40) (FUNCALL OLD-STREAM ':TYO CHAR))
111                         ((MEMQ CHAR '(10 11 15))
112                          (FUNCALL OLD-STREAM ':TYO (+ 200 CHAR)))
113                         ((MEMQ CHAR '(33))
114                          (FUNCALL OLD-STREAM ':TYO CHAR))
115                         ((MEMQ CHAR '(12 14)) )
116                         (T (FUNCALL OLD-STREAM ':TYO #/)
117                            (FUNCALL OLD-STREAM ':TYO (+ CHAR 100))))))
118           (OTHERWISE (LEXPR-FUNCALL OLD-STREAM OP ARGS)))))
119
120(IF-FOR-LISPM
121(DEFUN MAKE-CC-STREAM (&AUX (OLD-STREAM STANDARD-INPUT))
122  (SETQ CC-INPUT-STREAM (CLOSURE '(OLD-STREAM) 'CC-STREAM))
123  (LET ((OLD-STREAM STANDARD-OUTPUT))
124       (SETQ CC-OUTPUT-STREAM (CLOSURE '(OLD-STREAM) 'CC-STREAM)))))
125
126(IF-FOR-MACLISP
127(DEFUN MAKE-CC-STREAM () (SETQ CC-OUTPUT-STREAM T CC-INPUT-STREAM T))
128)
Note: See TracBrowser for help on using the repository browser.