source: project/release/4/picnic/trunk/calc-parser.scm @ 30645

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

picnic: reintegrated calculator language parser

File size: 5.4 KB
Line 
1
2(require-extension lalr-driver)
3
4;; parser
5
6(include "calc.yy.scm")
7
8;;;
9;;;;   The lexer
10;;;
11
12(define (port-line port) 
13  (let-values (((line _) (port-position port)))
14    line))
15 
16(define (port-column port)
17  (let-values (((_ column) (port-position port)))
18    column))
19
20(define (make-lexer errorp in)
21  (lambda ()
22    (letrec ((skip-spaces
23              (lambda ()
24                (let loop ((c (peek-char in)))
25                  (if (and (not (eof-object? c))
26                           (or (char=? c #\space) (char=? c #\tab)))
27                      (begin
28                        (read-char in)
29                        (loop (peek-char in)))))))
30             (skip-line
31              (lambda ()
32                (let loop ((c (peek-char in)))
33                  (if (and (not (eof-object? c)) (not (char=? c #\newline)) (not (char=? c #\return)))
34                      (begin
35                        (read-char in)
36                        (loop (peek-char in)))
37                      ))
38                ))
39             (read-number
40              (lambda (l)
41                (let ((c (peek-char in)))
42                  (if (or (char-numeric? c) (char=? #\. c) (char=? #\- c) (char=? #\e c))
43                      (read-number (cons (read-char in) l))
44                      (string->number (apply string (reverse l))) ))
45                ))
46             (read-id
47              (lambda (l)
48                (let ((c (peek-char in)))
49                  (if (or (char-alphabetic? c) (char=? #\_ c))
50                      (read-id (cons (read-char in) l))
51                      (string->symbol (apply string (reverse l))) ))
52                ))
53             (read-string
54              (lambda (l)
55               (let ([c (peek-char in)])
56                 (cond [(eq? 'eof c)   (errorp "unexpected end of string constant")]
57                       [(char=? c #\\) (let ((n (read-char in)))
58                                         (read-string (cons n l)))]
59                       [(char=? c #\") (begin (read-char in) (apply string (reverse l))) ]
60                       [else (read-string (cons (read-char in) l))] ))
61               ))
62             )
63
64      ;; -- skip spaces
65      (skip-spaces)
66      ;; -- read the next token
67      (let loop ()
68        (let* ((location (make-source-location "*stdin*" (port-line in) (port-column in) -1 -1))
69               (c (read-char in)))
70          (cond ((eof-object? c)      '*eoi*)
71                ((char=? c #\newline) (make-lexical-token 'NEWLINE location #f))
72                ((char=? c #\+)       (make-lexical-token '+       location #f))
73                ((char=? c #\-)       (make-lexical-token '-       location #f))
74                ((char=? c #\*)       (make-lexical-token '*       location #f))
75                ((char=? c #\/)       (let ((n (peek-char in)))
76                                        (if (char=? n #\/)
77                                            (begin (skip-line) (loop))
78                                            (make-lexical-token '/ location #f))))
79                ((char=? c #\=)       (make-lexical-token '=       location #f))
80                ((char=? c #\,)       (make-lexical-token 'COMMA   location #f))
81                ((char=? c #\()       (make-lexical-token 'LPAREN  location #f))
82                ((char=? c #\))       (make-lexical-token 'RPAREN  location #f))
83                ((char=? c #\")       (make-lexical-token 'STRING  location (read-string (list c))))
84                ((char-numeric? c)    (make-lexical-token 'NUM     location (read-number (list c))))
85                ((char-alphabetic? c) (make-lexical-token 'ID      location (read-id (list c))))
86                (else
87                 (errorp "PARSE ERROR : illegal character: " c)
88                 (skip-spaces)
89                 (loop))))))))
90
91
92
93;;;
94;;;;   Environment management
95;;;
96
97
98(define *env* (make-parameter (list (cons '$$ 0))))
99
100
101(define (init-bindings)
102  (*env* (list (cons '$$ 0)))
103  (add-binding 'PI 3.14159265358979)
104  (add-binding 'int round)
105  (add-binding 'cos cos)
106  (add-binding 'sin sin)
107  (add-binding 'tan tan)
108  (add-binding 'expt expt)
109  (add-binding 'sqrt sqrt)
110  (add-binding 'loadPoints load-points-from-file)
111  )
112
113
114(define (add-binding var val)
115  (*env* (cons (cons var val) (*env*)))
116  val)
117
118
119(define (get-binding var)
120  (let ((p (assq var (*env*))))
121    (if p
122        (cdr p)
123        0)))
124
125
126(define (invoke-func proc-name args)
127  (let ((proc (get-binding proc-name)))
128    (if (procedure? proc)
129        (apply proc args)
130        (begin
131          (display "ERROR: invalid procedure:")
132          (display proc-name)
133          (newline)
134          0))))
135
136
137;; (init-bindings)
138
139(define (errorp message . args)
140  (display message)
141  (if (and (pair? args) 
142           (lexical-token? (car args)))
143      (let ((token (car args)))
144        (display (or (lexical-token-value token)
145                     (lexical-token-category token)))
146        (let ((source (lexical-token-source token)))
147          (if (source-location? source)
148              (let ((line (source-location-line source))   
149                    (column (source-location-column source)))
150                (if (and (number? line) (number? column))
151                    (begin
152                      (display " (at line ")
153                      (display line)
154                      (display ", column ")
155                      (display (+ 1 column))
156                      (display ")")))))))
157      (for-each display args))
158  (newline))
159
160(define (calc-lexer in) (make-lexer errorp in))
161
162(define (calc-eval lexer) (calc-parser lexer errorp))
163
164(define (calc-eval-string s) 
165  (calc-parser (calc-lexer (open-input-string (string-append s "\n"))) errorp))
166
Note: See TracBrowser for help on using the repository browser.