Commit | Line | Data |
---|---|---|
82a4bd91 C |
1 | (setq rcs-syntax- |
2 | "$Header: /usr/lib/lisp/syntax.l,v 1.1 83/01/29 18:40:24 jkf Exp $") | |
3 | ||
4 | ;; | |
5 | ;; syntax.l -[Sat Jan 29 18:28:58 1983 by jkf]- | |
6 | ;; | |
7 | ;; contains the user callable setsyntax function | |
8 | ;; | |
9 | ||
10 | ||
11 | ;--- setsyntax :: new version of setsyntax | |
12 | ; this version allows symbolic syntax codes. | |
13 | ; | |
14 | (declare | |
15 | (special syntax:symbolic-to-old-fixnum ;; for upward compatibility | |
16 | ; use this to map from old | |
17 | ; fixnums to symbolic names | |
18 | syntax:symbolic-bits-to-fixnum ;; bit definitions of symbolic | |
19 | ;bits. see h/chars.h | |
20 | syntax:code-to-bits ;; used at runtime to | |
21 | ; interpret symbolic names | |
22 | readtable ;; current readtable | |
23 | )) | |
24 | ||
25 | ||
26 | (def setsyntax | |
27 | (lexpr (n) | |
28 | (cond ((not (or (equal n 2) (equal n 3))) | |
29 | (error "setsyntax: 2 or 3 args required, not " n))) | |
30 | ; determine the correct code | |
31 | (prog (given ch number) | |
32 | (setq given (arg 2) | |
33 | ch (arg 1)) | |
34 | (cond ((and (not (numberp ch)) | |
35 | (not (symbolp ch))) | |
36 | (error "setsyntax: first arg must be a number or symbol: " | |
37 | ch))) | |
38 | (cond ((numberp given) | |
39 | ; using the old fixnum values (we suppose) | |
40 | (cond ((setq number | |
41 | (rassq given syntax:symbolic-to-old-fixnum)) | |
42 | (setq given (car number))) ; use symbolic name | |
43 | (t (error "setsyntax: fixnum code is not defined: " | |
44 | given))))) | |
45 | (cond ((symbolp given) | |
46 | ; convert from common names to our symbolic names | |
47 | (cond ((eq 'macro given) | |
48 | (setq given 'vmacro)) | |
49 | ((eq 'splicing given) | |
50 | (setq given 'vsplicing-macro))) | |
51 | ; now see if the symbolic name is defined | |
52 | (cond ((setq number (assq given syntax:code-to-bits)) | |
53 | (setq number (cdr number))) | |
54 | (t (error "setsyntax: unknown symbolic code: " | |
55 | given)))) | |
56 | (t (error "setsyntax: second arg not symbol or fixnum: " | |
57 | given))) | |
58 | ; now call the low level code to set the value. | |
59 | (int:setsyntax (arg 1) number) ;;; change to * | |
60 | ; the final argument is placed on the property list of the | |
61 | ; first argument, with the indicator being the current readtable, | |
62 | ; thus you can have more than one macro function for each | |
63 | ; character for each readtable. | |
64 | (cond ((equal n 3) | |
65 | (cond ((numberp ch) (setq ch (ascii ch)))) ; need symbol | |
66 | (putprop ch (arg 3) readtable)))) | |
67 | t)) | |
68 | ||
69 | ||
70 | (def getsyntax | |
71 | (lambda (ch) | |
72 | (let ((res (int:getsyntax ch)) ; this will be modified too | |
73 | (symb)) | |
74 | (cond ((setq symb (rassq res syntax:code-to-bits)) | |
75 | (car symb)) | |
76 | (t (error "getsyntax: no symbolic code corresponds to: " | |
77 | res)))))) | |
78 | ||
79 | ||
80 | ;--- add-syntax-class : add a new symbolic syntax class | |
81 | ; name is the name which we will use to refer to it. | |
82 | ; bits are a list of symbolic bit names for it. | |
83 | ; modifies global variable: syntax:code-to-bits | |
84 | ; | |
85 | (def add-syntax-class | |
86 | (lambda (name bits) | |
87 | (cond ((not (symbolp name)) | |
88 | (error "add-syntax-class: illegal name: " name))) | |
89 | (cond ((not (dtpr bits)) | |
90 | (error "add-syntax-class: illegal bits: " bits))) | |
91 | (do ((xx bits (cdr xx)) | |
92 | (this 0) | |
93 | (num 0)) | |
94 | ((null xx) | |
95 | (cond ((setq this (assq name syntax:code-to-bits)) | |
96 | (rplacd this num)) ; replace old value | |
97 | (t (setq syntax:code-to-bits (cons (cons name num) | |
98 | syntax:code-to-bits))))) | |
99 | (cond ((setq this (assq (car xx) syntax:symbolic-bits-to-fixnum)) | |
100 | ;(format t "num:~d, oth:~a, comb:~d~%" | |
101 | ; num (cdr this) (apply 'boole `(7 ,num ,(cdr this)))) | |
102 | (setq num (boole 7 num (cdr this))) | |
103 | ;(format t "res: ~d~%" num) | |
104 | ) ; logical or | |
105 | (t (error "illegal syntax code " (car xx))))) | |
106 | name)) | |
107 | ||
108 | (setq syntax:symbolic-to-old-fixnum | |
109 | '((vnumber . 0) (vsign . 1) (vcharacter . 2) | |
110 | (vsingle-character-symbol . 66.) | |
111 | (vleft-paren . 195.) (vright-paren . 196.) | |
112 | (vperiod . 133.) | |
113 | (vleft-bracket . 198.) (vright-bracket . 199.) (veof . 200.) | |
114 | (vsingle-quote . 201.) (vsymbol-delimiter . 138.) | |
115 | (vstring-delimiter . 137.) | |
116 | (villegal . 203.) (vseparator . 204.) | |
117 | (vsplicing-macro . 205.) (vmacro . 206.) | |
118 | (vescape . 143.)) | |
119 | syntax:symbolic-bits-to-fixnum | |
120 | '(; character classes | |
121 | (cnumber . 0) (csign . 1) (ccharacter . 2) | |
122 | (cleft-paren . 3) | |
123 | (cright-paren . 4) (cperiod . 5) (cleft-bracket . 6) | |
124 | (cright-bracket . 7) | |
125 | (csingle-quote . 9.) (csymbol-delimiter . 10.) (cillegal . 11.) | |
126 | (cseparator . 12.) (csplicing-macro . 13.) | |
127 | (cmacro . 14.) (cescape . 15.) (csingle-character-symbol . 16.) | |
128 | (cstring-delimiter . 17.) | |
129 | (csingle-macro . 18.) (csingle-splicing-macro . 19.) | |
130 | (cinfix-macro . 20.) | |
131 | (csingle-infix-macro . 21.) | |
132 | ; escape bits | |
133 | (escape-when-unique . 64.) | |
134 | (escape-when-first . 128.) | |
135 | (escape-always . 192.) | |
136 | ; separator | |
137 | (separator . 32.)) | |
138 | syntax:code-to-bits nil) | |
139 | ||
140 | (add-syntax-class 'vnumber '(cnumber)) | |
141 | (add-syntax-class 'vsign '(csign)) | |
142 | (add-syntax-class 'vcharacter '(ccharacter)) | |
143 | (add-syntax-class 'vleft-paren '(cleft-paren escape-always separator)) | |
144 | (add-syntax-class 'vright-paren '(cright-paren escape-always separator)) | |
145 | (add-syntax-class 'vperiod '(cperiod escape-when-unique)) | |
146 | (add-syntax-class 'vleft-bracket '(cleft-bracket escape-always separator)) | |
147 | (add-syntax-class 'vright-bracket '(cright-bracket escape-always separator)) | |
148 | (add-syntax-class 'vsingle-quote '(csingle-quote escape-always separator)) | |
149 | (add-syntax-class 'vsymbol-delimiter '(csymbol-delimiter escape-always)) | |
150 | (add-syntax-class 'villegal '(cillegal escape-always separator)) | |
151 | (add-syntax-class 'vseparator '(cseparator escape-always separator)) | |
152 | (add-syntax-class 'vsplicing-macro '(csplicing-macro escape-always separator)) | |
153 | (add-syntax-class 'vmacro '(cmacro escape-always separator)) | |
154 | (add-syntax-class 'vescape '(cescape escape-always)) | |
155 | (add-syntax-class 'vsingle-character-symbol | |
156 | '(csingle-character-symbol separator)) | |
157 | (add-syntax-class 'vstring-delimiter '(cstring-delimiter escape-always)) | |
158 | (add-syntax-class 'vsingle-macro '(csingle-macro escape-when-unique)) | |
159 | (add-syntax-class 'vsingle-splicing-macro | |
160 | '(csingle-splicing-macro escape-when-unique)) | |
161 | (add-syntax-class 'vinfix-macro '(cinfix-macro escape-always separator)) | |
162 | (add-syntax-class 'vsingle-infix-macro | |
163 | '(csingle-infix-macro escape-when-unique)) | |
164 | ||
165 |