source: project/release/4/picnic/trunk/expr-parser.scm @ 30637

Last change on this file since 30637 was 30637, checked in by Ivan Raikov, 7 years ago

npccl renamed to picnic

File size: 7.6 KB
Line 
1
2;; Chicken Scheme implementation of the box routines.  Based on
3;; dfa2.sc in the benchmarks code supplied with Stalin 0.11
4
5(define-record-type box (make-box contents)
6  box? (contents box-contents box-contents-set!))
7
8(define box make-box)
9(define unbox box-contents)
10(define set-box! box-contents-set!)
11
12;; Stack routines.  Based on dfa2.sc in the benchmarks code supplied
13;; with Stalin 0.11
14
15(define (make-stack)
16  (box '()))
17
18(define (stack-empty? s)
19  (null? (unbox s)))
20
21(define (stack-push! s obj)
22  (set-box! s (cons obj (unbox s)))
23  s)
24
25(define (stack-pop! s)
26  (let ((l (unbox s)))
27    (set-box! s (cdr l))
28    (car l)))
29
30(define (stack-cut! s start end)
31  (cond
32   ((negative? start)
33    (error 'stack-cut! "start depth must be >= 0"))
34   ((negative? end)
35    (error 'stack-cut! "end depth must be >= 0"))
36   ((< end start)
37    (error 'stack-cut! "start depth must be <= to the end depth")))
38  (let ((l (unbox s)))
39    (let loop ((i 0) (l l) (nl (list)))
40      (if (null? l) (set-box! s (reverse nl))
41          (if (and (>= i start) (<= i end))
42              (loop (+ i 1) (cdr l) nl)
43              (loop (+ i 1) (cdr l) (cons (car l) nl))))))
44  s)
45
46(define (stack-depth s)
47  (let ((l (unbox s)))
48    (length l)))
49
50(define (stack-peek s)
51  (let ((l (unbox s)))
52    (car l)))
53
54(define stack->list unbox)
55(define (list->stack lst)
56  (and (pair? lst) (box lst)))
57
58(define-syntax tok
59  (syntax-rules ()
60    ((tok loc t) (make-lexical-token (quasiquote t) loc #f))
61    ((tok loc t l) (make-lexical-token (quasiquote t) loc l))))
62
63(define (make-parse-error loc)
64  (lambda (msg #!optional arg)
65    (let ((loc-str (or (and loc (if (list? loc) (conc " " loc " ") (conc " (" loc ") "))) "")))
66      (cond  [(not arg) (error loc-str msg)]
67             [(lexical-token? arg)
68              (picnic:error (conc "line " (source-location-line (lexical-token-source arg)) ": " msg) loc-str
69                     (conc (lexical-token-category arg) 
70                           (if (lexical-token-value arg) (conc " " (lexical-token-value arg)) "")))]
71             [else (picnic:error loc-str (conc msg arg))]
72             ))))
73
74
75(define (make-char-lexer port errorp loc)
76  (lambda ()
77    (letrec ((skip-spaces
78              (lambda ()
79                (let loop ((c (peek-char port)))
80                  (if (and (not (eof-object? c))
81                           (or (char=? c #\space) (char=? c #\tab)))
82                      (begin
83                        (read-char port)
84                        (loop (peek-char port)))))))
85             (read-number
86              (lambda (l e? minus?)
87                (let ((c (peek-char port)))
88                  (if (and (char? c) 
89                           (or (char-numeric? c) (case c ((#\. #\e) c) (else #f))
90                               (and e? (not minus?) (char=? c #\-))))
91                      (read-number (cons (read-char port) l)
92                                   (or e? (char=? c #\e))
93                                   (or minus? (char=? c #\-)))
94                      (let ((s (list->string (reverse l))))
95                        (let ((n (string->number s)))
96                          (if (not n) (errorp "invalid numeric string: " s) n))
97                          )))))
98             (read-id
99              (lambda (l)
100                (let ((c (peek-char port)))
101                  (if (and (char? c) (or (char-alphabetic? c) (char-numeric? c) (char=? c #\_)))
102                      (read-id (cons (read-char port) l))
103                      (string->symbol (apply string (reverse l)))))))
104             (read-string
105              (lambda (l)
106                (let ((c (peek-char port)))
107                  (cond ((and (char? c) (or (char-alphabetic? c) (char-numeric? c) 
108                                            (char-whitespace? c) (char=? c #\_)))
109                         (read-string (cons (read-char port) l)))
110                        ((char=? c #\")
111                         (begin
112                           (read-char port)
113                           (string->symbol (apply string (reverse l)))))
114                        (else
115                         (errorp "invalid string character: " c))
116                        ))
117                ))
118             )
119
120      ;; -- skip spaces
121      (skip-spaces)
122      ;; -- read the next token
123      (let loop ((c (read-char port)))
124        (cond
125         ((eof-object? c)      '*eoi*)
126         ((char=? c #\>)       '>)
127         ((char=? c #\<)       '<)
128         ((char=? c #\^)       '^)
129         ((char=? c #\+)       '+)
130         ((char=? c #\-)       (let ((k (peek-char port)))
131                                 (if (or (char-numeric? k) (char=? k #\.))
132                                     (let ((n (read-number (list c) #f #f)))
133                                       (tok loc NUM n)) '-)))
134         ((char=? c #\*)       '*)
135         ((char=? c #\/)       '/)
136         ((char=? c #\=)       '=)
137         ((char=? c #\?)       (tok loc QUESTION))
138         ((char=? c #\:)       (tok loc COLON))
139         ((char=? c #\,)       (tok loc COMMA))
140         ((char=? c #\~)       (tok loc COMMA))
141         ((char=? c #\()       (tok loc LPAREN))
142         ((char=? c #\))       (tok loc RPAREN))
143         ((or (char-numeric? c)  (char=? c #\.) (char=? c #\-))
144          (tok loc NUM (read-number (list c) #f #f)))
145         ((char=? c #\")
146          (read-string (list)))
147         ((char-alphabetic? c) 
148          (let ((id (read-id (list c))))
149            (case id
150              ((let LET Let)       (tok loc LET))
151              ((if IF If)          (tok loc IF))
152              ((then THEN Then)    (tok loc THEN))
153              ((else ELSE Else)    (tok loc ELSE))
154              (else
155               (tok loc ID id)))
156            ))
157         ((or (char=? c #\space) 
158              (char=? c #\tab)
159              (char=? c #\newline)
160              (char=? c #\return))
161          (loop (read-char port)))
162         (else
163          (errorp "illegal character: " c)
164          (skip-spaces)
165          (loop (read-char port))))))))
166
167(include "expr.grm.scm")
168
169(define (port-line port) 
170  (let-values (((line _) (port-position port)))
171    line))
172 
173(define (port-column port)
174  (let-values (((_ column) (port-position port)))
175    column))
176
177(define (picnic:parse-string-expr s #!optional loc)
178  (or (and (string? s) (string-null? s) '())
179      (let ((port
180             (cond ((string? s)  (open-input-string s))
181                   ((port? s)    s)
182                   (else (error 'picnic:parse-string-expr "bad argument type: not a string or a port: " s)))))
183        (expr-parser  (let ((ll (make-char-lexer port (make-parse-error loc) (make-source-location loc (port-line port) (port-column port) -1 -1))))
184                        (lambda ()
185                          (let ((t (ll)))
186                            t)))
187                      (make-parse-error loc)
188                      ))))
189
190(define (make-sym-lexer lst errorp loc)
191  (if (not (list? lst)) (errorp "illegal list: " lst))
192  (let ((is (make-stack)))
193    (stack-push! is lst)
194    (lambda ()
195      (if (stack-empty? is)  '*eoi*
196          (let* ((p     (stack-pop! is))
197                 (x     (and (not (null? p)) (car p)))
198                 (t     (if x
199                            (begin (stack-push! is (cdr p))
200                                   (match x
201                                          ((or '< '> '>= '<= '^ '+ '- '* '/ '= )      x)
202                                          ('?           (tok loc QUESTION))
203                                          (':           (tok loc COLON))
204                                          ('~           (tok loc COMMA))
205                                          ((or 'let 'LET)     (tok loc LET))
206                                          ((or 'if 'IF)       (tok loc IF))
207                                          ((or 'then 'THEN)   (tok loc THEN))
208                                          ((or 'else 'ELSE)   (tok loc ELSE))
209                                          ((? string?)  (tok loc STRING x))
210                                          ((? number?)  (tok loc NUM x))
211                                          ((? symbol?)  (tok loc ID x))
212                                          ((? list?)    (begin
213                                                          (stack-push! is x)
214                                                          (tok loc LPAREN)))
215                                          (else (errorp "invalid input: " x))))
216                            (if (not (stack-empty? is)) (tok loc RPAREN) '*eoi*))))
217            t)))))
218           
219 
220
221(define (picnic:parse-sym-expr lst #!optional loc)
222  (let ((ret (cond ((number? lst)  lst)
223                   ((symbol? lst)  lst)
224                   ((and (list? lst) (null? lst) '()))
225                   (else (expr-parser  (make-sym-lexer lst (make-parse-error loc) (make-source-location loc 0 0 -1 -1))
226                                       (make-parse-error loc))))))
227    ret))
228   
229
230
Note: See TracBrowser for help on using the repository browser.