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