![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to syntax.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib|
Return to syntax.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib |
1.1 root 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:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.