![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to scanner.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / fp|
Return to scanner.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / fp |
1.1 root 1: ; FP interpreter/compiler
2: ; Copyright (c) 1982 Scott B. Baden
3: ; Berkeley, California
4: ;
5: ; Copyright (c) 1982 Regents of the University of California.
6: ; All rights reserved. The Berkeley software License Agreement
7: ; specifies the terms and conditions for redistribution.
8: ;
9: (setq SCCS-scanner.l "@(#)scanner.l 5.1 (Berkeley) 5/31/85")
10:
11: ; Scanner code.
12:
13: ; get the next token: names, numbers, special symbols
14: ; this is the top-level scanner section.
15:
16: (include specials.l)
17: (declare (localf alpha$ numer$ get_num$ get_nam$ namtyp two_kind))
18:
19: (defun get_tkn nil
20: (do ((char_num (Getc) (Getc))
21: (scan_fn nil))
22:
23: ((eq char_num -1) (*throw 'parse$err 'eof$$)) ; eof control D
24:
25: ; if the first character is a letter then the next token is a name
26:
27: (cond ((alpha$ char_num) (return (namtyp char_num)))
28:
29: ; if the first character is a number then next token is a number
30:
31: ((numer$ char_num) (return
32: (list 'select$$
33: (get_num$ char_num))))
34:
35: ((memq char_num #.whiteSpace))
36: ((eq char_num 35) (clr_teol)) ; # is the comment char.
37: (t (setq scan_fn (get char_set (ascii char_num)))
38: (cond ((null scan_fn)
39: (*throw 'parse$err `(err$$ bad_char ,(ascii char_num))))
40: (t (return (funcall scan_fn))))))))
41:
42: ; these are the scanner action functions
43:
44:
45: (defun (scan$asc |[|) nil
46: 'lbrack$$)
47:
48: (defun (scan$asc |]|) nil
49: 'rbrack$$)
50:
51: (defun (scan$asc |{|) nil
52: 'lbrace$$)
53:
54: (defun (scan$asc |}|) nil
55: 'rbrace$$)
56:
57: (defun (scan$asc |(|) nil
58: 'lparen$$)
59:
60: (defun (scan$asc |)|) nil
61: 'rparen$$)
62:
63: (defun (scan$asc |@|) nil
64: 'compos$$)
65:
66: (defun (scan$asc |!|) nil
67: 'insert$$)
68:
69: (defun (scan$asc |\||) nil ; tree insert
70: 'ti$$)
71:
72: (defun (scan$asc |&|) nil
73: 'alpha$$)
74:
75: (defun (scan$asc |;|) nil
76: 'semi$$)
77:
78: (defun (scan$asc |:|) nil
79: 'colon$$)
80:
81: (defun (scan$asc |,|) nil
82: 'comma$$)
83:
84:
85: (defun (scan$asc |+|) nil ; plus or pos select
86: (cond ((numer$ (peekc)) (list 'select$$ (get_num$ #/0)))
87: (t '(builtin$$ plus))))
88:
89:
90: (defun (scan$asc |*|) nil
91: '(builtin$$ times))
92:
93: (defun (scan$asc |/|) nil
94: '(builtin$$ div))
95:
96: (defun (scan$asc |=|) nil
97: '(builtin$$ eq))
98:
99:
100: ; either a 1 or 2-char token
101: (defun (scan$asc |-|) nil
102: (cond ((numer$ (peekc)) ; subtract or neg select
103: (list 'select$$ (minus (get_num$ #/0))))
104: (t (two_kind #/> 'arrow$$ '(builtin$$ sub))))) ; or arrow
105:
106: (defun (scan$asc |>|) nil ; > or >=
107: (two_kind #/= '(builtin$$ ge) '(builtin$$ gt)))
108:
109: (defun (scan$asc |<|) nil ; < or <=
110: (two_kind #/= '(builtin$$ le) '(builtin$$ lt)))
111:
112: (defun (scan$asc |~|) nil ; ~= or error
113: (two_kind #/= '(builtin$$ ne)
114: `(badtkn$$ ,(ascii char_num))))
115:
116:
117: ; if a % then read in the next constant (object)
118:
119: (defun (scan$asc |%|) nil
120: (let ((v (get_obj nil)))
121: (list 'constant$$ (list 'quote v))))
122:
123:
124: ; these are the support routines
125:
126: ; routine to tell if a character is a letter
127:
128: (defun alpha$ (x)
129: (or (and (greaterp x 96) (lessp x 123))
130: (and (greaterp x 64) (lessp x 91))))
131:
132:
133: ; routine to tell if character is a number
134:
135: (defun numer$ (x)
136: (and (greaterp x 47) (lessp x 58)))
137:
138:
139: ; routine to read in a number
140:
141: (defun get_num$ (first_c)
142: (do ((num$ (diff first_c 48 ))
143: (c (peekc) (peekc)))
144: ((memq c num_delim$) (return num$))
145: (cond ((not (numer$ c)) (*throw 'parse$err '(err$$ badnum)))
146: (t (setq num$ (plus (times 10 num$) (diff (Getc) 48 )))))))
147:
148:
149:
150: ; routine to read in a name
151:
152: (defun get_nam$ (first_c)
153: (do ((name$ (cons first_c nil))
154: (c (peekc) (peekc)))
155: ((not (or (numer$ c) (alpha$ c) (eq #/_ c))) (implode (nreverse name$)))
156: (setq name$ (cons (Getc) name$))))
157:
158: ; routine to determine whether the name represents a builtin
159: ; or not
160:
161: (defun namtyp (c)
162: (let ((x (get_nam$ c)))
163: (cond ((eq x 'while) 'while$$)
164: (t (list
165: (cond ((null (memq x builtins)) 'defined$$)
166: (t 'builtin$$)) x)))))
167:
168:
169: ; read in a lisp sequence
170:
171: (defun readit nil
172: (If (not (memq (car in_buf) '(< % :)))
173: then (setq in_buf (cons 32 in_buf)))
174:
175: (setq in_buf (cons #/< in_buf))
176: (cond ((and ptport (null infile)) (patom '< ptport)))
177: (let ((readtable newreadtable))
178: (do ((xx (*catch 'parse$err (get_obj t)) (*catch 'parse$err (get_obj t)))
179: (result nil))
180: ((eq xx '>) (nreverse result))
181:
182: (cond ((find 'err$$ xx) (*throw 'parse$err `(err$$ bad_obj ,xx))))
183: (cond ((eq '\, xx))
184: (t (setq result (cons xx result)))))))
185:
186:
187: ; peek ahead to see if the single character token in really
188: ; a double character token
189:
190: (defun two_kind (char2 dbl_nm sing_nm)
191: (cond ((eq (peekc) char2)
192: (prog (dummy)
193: (setq dummy (Getc)) (return dbl_nm)))
194: (t sing_nm)))
195:
196: ; check if any ? (bottom) in sequence
197:
198: (defun chk_bot$ (x)
199: (cond ((atom x) (eq x '?))
200: (t (or (chk_bot$ (car x)) (chk_bot$ (cdr x))))))
201:
202: ; get an object and check for bottom (?) or errors (reserved symbols)
203:
204: (defun get_obj (read_seq)
205: (let ((readtable newreadtable))
206: (prog (x)
207: (setq x (read_inp))
208: (cond ((chk_bot$ x) (return '?))
209: ((boolp x) (return x))
210: ((and (atom x) (memq x '(|,| |>|)))
211: (cond (read_seq (return x))
212: (t (*throw 'parse$err '(err$$ bad_comma)))))
213: ((and (atom x) (memq x '(+ -)))
214: (cond ((numer$ (peekc))
215: (let ((z (*catch 'parse$err (get_obj nil))))
216: (cond ((find 'err$$ z)
217: (*throw 'parse$err `(err$$ bad_num ,z)))
218: ((not (numberp z))
219: (*throw 'parse$err `(err$$ bad_num ,z)))
220: (t (cond ((eq x '+) (return z))
221: (t (return (diff z))))))))
222: (t (*throw 'parse$err `(err$$ bad_num ,x)))))
223: ((and (symbolp x) (numer$ (car (exploden x))))
224: (*throw 'parse$err `(err$$ bad_num ,x)))
225: ((and (atom x) (memq x e_rsrvd)) (*throw 'parse$err `(err$$ bad_obj ,x)))
226: (t (return x))))))
227:
228:
229: (defun read_inp nil
230: (let ((c
231: (let ((piport infile))
232: (Read))))
233: (If (not (listp c))
234: then (let ((ob (exploden c)))
235: (let ((OB
236: (If (and (not (= (car in_buf) #/<))
237: (not (= (car in_buf) #/>))
238: (not (= c '>)))
239: then (cons 32 ob)
240: else ob)))
241:
242: (If (onep (length OB))
243: then (setq in_buf (cons (car OB) in_buf))
244: else (setq in_buf (append (reverse OB) in_buf))))))
245: c))
246:
247:
248:
249: (defun clr_teol nil
250: (let ((piport infile))
251: (do ((c (Getc) (Getc)))
252: ((eq c #.CR)
253: (cond ((not in_def) (setq in_buf nil)))
254: (cond ((and (not infile) (not in_def))
255: (patom " ")))))))
256:
257: (defun p_strng (s)
258: (patom (ascii s)))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.