1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
|
;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
;; All rights reserved.
;; Copyright (C) 2007-2009, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;;
;; - Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;;
;; - Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in
;; the documentation and/or other materials provided with the
;; distribution.
;;
;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the
;; names of its contributors may be used to endorse or promote products
;; derived from this software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
; PURPOSE: This file sets up properties which are used by the Boot lexical
; analyzer for bottom-up recognition of operators. Also certain
; other character-class definitions are included, as well as
; table accessing functions.
;
; ORGANIZATION: Each section is organized in terms of Creation and Access code.
;
; 1. Led and Nud Tables
; 2. GLIPH Table
; 3. RENAMETOK Table
; 4. GENERIC Table
; 5. Character syntax class predicates
; **** 1. LED and NUD Tables
; ** TABLE PURPOSE
; Led and Nud have to do with operators. An operator with a Led property takes
; an operand on its left (infix/suffix operator).
; An operator with a Nud takes no operand on its left (prefix/nilfix).
; Some have both (e.g. - ). This terminology is from the Pratt parser.
; The translator for Scratchpad II is a modification of the Pratt parser which
; branches to special handlers when it is most convenient and practical to
; do so (Pratt's scheme cannot handle local contexts very easily).
; Both LEDs and NUDs have right and left binding powers. This is meaningful
; for prefix and infix operators. These powers are stored as the values of
; the LED and NUD properties of an atom, if the atom has such a property.
; The format is:
; <Operator Left-Binding-Power Right-Binding-Power <Special-Handler>>
; where the Special-Handler is the name of a function to be evaluated when that
; keyword is encountered.
; The default values of Left and Right Binding-Power are NIL. NIL is a
; legitimate value signifying no precedence. If the Special-Handler is NIL,
; this is just an ordinary operator (as opposed to a surfix operator like
; if-then-else).
(IMPORT-MODULE "macros")
(in-package "BOOT")
; ** TABLE CREATION
(defparameter OpAssoc nil
"Information used by OUT BOOT operator pretty printing routines")
(defun MAKENEWOP (X Y) (MAKEOP X Y '|PARSE-NewKEY|))
(defun MAKEOP (X Y KEYNAME)
(if (OR (NOT (CDR X)) (NUMBERP (SECOND X)))
(SETQ X (CONS (FIRST X) X)))
(if (AND (alpha-char-p (ELT (STRINGIMAGE (FIRST X)) 0))
(NOT (MEMBER (FIRST X) (EVAL KEYNAME))))
(SET KEYNAME (CONS (FIRST X) (EVAL KEYNAME))))
(MAKEPROP (FIRST X) Y X)
(SETQ OPASSOC (ADDASSOC Y (CONS (CONS X X) (LASSOC Y OPASSOC)) OPASSOC))
(SECOND X))
(defvar |PARSE-NewKEY| nil) ;;list of keywords
(mapcar #'(LAMBDA(J) (MAKENEWOP J '|Led|))
'((* 800 801) (|rem| 800 801) (|mod| 800 801)
(|quo| 800 801) (|div| 800 801)
(/ 800 801) (** 900 901) (^ 900 901)
(|exquo| 800 801) (+ 700 701)
(\- 700 701) (\-\> 1001 1002) (\<\- 1001 1002)
(\: 996 997) (\:\: 996 997)
(\@ 996 997) (|pretend| 995 996)
(\.) (\! \! 1002 1001)
(\, 110 111)
(\; 81 82 (|PARSE-SemiColon|))
(\< 400 400) (\> 400 400)
(\<\< 400 400) (\>\> 400 400)
(\<= 400 400) (\>= 400 400)
(= 400 400) (^= 400 400)
(\~= 400 400)
(|in| 400 400) (|case| 400 400)
(|add| 400 120) (|with| 2000 400 (|PARSE-InfixWith|))
(|has| 400 400)
(|where| 121 104) ; must be 121 for SPAD, 126 for boot--> nboot
(|when| 112 190)
(|is| 400 400) (|isnt| 400 400)
(|and| 250 251) (|or| 200 201)
(/\\ 250 251) (\\/ 200 201)
(\.\. SEGMENT 401 699 (|PARSE-Seg|))
(=\> 123 103)
(+-\> 998 112)
(== DEF 122 121)
(==\> MDEF 122 121)
(\| 108 111) ;was 190 190
(\:- LETD 125 124) (\:= %LET 125 124)))
(mapcar #'(LAMBDA (J) (MAKENEWOP J `|Nud|))
'((|for| 130 350 (|PARSE-Loop|))
(|while| 130 190 (|PARSE-Loop|))
(|until| 130 190 (|PARSE-Loop|))
(|repeat| 130 190 (|PARSE-Loop|))
(|import| 120 0 (|PARSE-Import|) )
(|inline| 120 0 (|PARSE-Inline|) )
(|unless|)
(|add| 900 120)
(|with| 1000 300 (|PARSE-With|))
(|has| 400 400)
(\- 701 700) ; right-prec. wants to be -1 + left-prec
;; (\+ 701 700)
(\# 999 998)
(\! 1002 1001)
(\' 999 999 (|PARSE-Data|))
(\<\< 122 120 (|PARSE-LabelExpr|))
(\>\>)
(^ 260 259 NIL)
(\-\> 1001 1002)
(\: 194 195)
(|not| 260 259 NIL)
(\~ 260 259 nil)
(\= 400 700)
(|return| 202 201 (|PARSE-Return|))
(|leave| 202 201 (|PARSE-Leave|))
(|exit| 202 201 (|PARSE-Exit|))
(|from|)
(|iterate|)
(|yield|)
(|if| 130 0 (|PARSE-Conditional|)) ; was 130
(|case| 130 190 (|PARSE-Match|))
(\| 0 190)
(|suchthat|)
(|then| 0 114)
(|else| 0 114)))
;; Gliphs are symbol clumps. The gliph property of a symbol gives
;; the tree describing the tokens which begin with that symbol.
;; The token reader uses the gliph property to determine the longest token.
;; Thus `:=' is read as one token not as `:' followed by `='.
(mapcar #'(lambda (x) (makeprop (car x) 'gliph (cdr x)))
`(
( \| (\)) (]) )
( * (*) )
( \( (<) (\|) )
( + (- (>)) )
( - (>) )
( < (=) (<) )
( / (\\) )
( \\ (/) )
( > (=) (>) (\)))
( = (= (>)) (>) )
( \. (\.) )
( ^ (=) )
( \~ (=) )
( [ (\|) )
( \: (=) (-) (\:))))
;; RENAMETOK defines alternate token strings which can be used for different
;; keyboards which define equivalent tokens.
(mapcar
#'(lambda (x) (MAKEPROP (CAR X) 'RENAMETOK (CADR X)) (MAKENEWOP X NIL))
'((\(\| \[) ; (| |) means []
(\|\) \])
(\(< \{) ; (< >) means {}
(>\) \})))
;; GENERIC operators be suffixed by `$' qualifications in SPAD code.
;; `$' is then followed by a domain label, such as I for Integer, which
;; signifies which domain the operator refers to. For example `+$Integer'
;; is `+' for Integers.
(mapcar #'(lambda (x) (MAKEPROP X 'GENERIC 'TRUE))
'(- = * |rem| |mod| |quo| |div| / ** |exquo| + - < > <= >= ~= ))
(defun SPECIALCASESYNTAX () (OR (AND (char= TOK '#\#) (DIGITP CHR))))
(defun TERMINATOR (CHR)
(member CHR '(#\ #\( #\) #\. #\; #\, #\Return)) :test #'char=)
|
