source: project/release/4/nemo/trunk/expr-parser.scm @ 26990

Last change on this file since 26990 was 26990, checked in by Ivan Raikov, 9 years ago

nemo: removed deubg stmts from expression parser

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