Commit | Line | Data |
---|---|---|
06bed997 SB |
1 | ; FP interpreter/compiler |
2 | ; Copyright (c) 1982 Scott B. Baden | |
3 | ; Berkeley, California | |
edf71f48 DF |
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 | ; | |
95f51977 | 9 | (setq SCCS-scanner.l "@(#)scanner.l 5.1 (Berkeley) 5/31/85") |
06bed997 SB |
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))) |