original commit: 03b6cde1f73a31100fc18ddd2509dde79cccfe2e
tokens
Scott Owens 22 years ago
parent 01364cc5f3
commit e50edf3a00

@ -1,20 +1,41 @@
;; Constructs to create and access grammars, the internal
;; representation of the input to the parser generator.
#cs #cs
(module grammar mzscheme (module grammar mzscheme
(require (lib "class.ss") (require (lib "class.ss")
(lib "list.ss") (lib "list.ss")
"yacc-helper.ss") "yacc-helper.ss"
(lib "contracts.ss"))
;; Constructs to create and access grammars, the internal ;; Each production has a unique index 0 <= index <= number of productions
;; representation of the input to the parser generator. (define-struct prod (lhs rhs index prec action) (make-inspector))
;; The dot-pos field is the index of the element in the rhs
;; of prod that the dot immediately preceeds.
;; Thus 0 <= dot-pos <= (vector-length rhs).
(define-struct item (prod dot-pos) (make-inspector))
;; gram-sym = (or/f term? non-term?)
;; Each term has a unique index 0 <= index < number of terms
;; Each non-term has a unique index 0 <= index < number of non-terms
(define-struct term (sym index prec) (make-inspector))
(define-struct non-term (sym index) (make-inspector))
;; a precedence declaration.
(define-struct prec (num assoc) (make-inspector))
(provide/contract
(make-item (prod? (or/f false? natural-number?) . -> . item?))
(make-term (symbol? (or/f false? natural-number?) (or/f prec? false?) . -> . term?))
(make-non-term (symbol? (or/f false? natural-number?) . -> . non-term?))
(make-prec (natural-number? (symbols 'left 'right 'nonassoc) . -> . prec?))
(make-prod (non-term? (vectorof (or/f non-term? term?))
(or/f false? natural-number?) (or/f false? prec?) syntax? . -> . prod?)))
(provide (provide
make-item
make-term
make-non-term
make-prec
make-prod
;; Things that work on items ;; Things that work on items
start-item? item-prod item->string start-item? item-prod item->string
@ -36,12 +57,6 @@
;;---------------------- LR items -------------------------- ;;---------------------- LR items --------------------------
;; LR-item = (make-item production nat)
;; The dot-pos field is the index of the element in the rhs
;; of prod that the dot immediately preceeds.
;; Thus 0 <= dot-pos <= (vector-length rhs).
(define-struct item (prod dot-pos) (make-inspector))
;; item<?: LR-item * LR-item -> bool ;; item<?: LR-item * LR-item -> bool
;; Lexicographic comparison on two items. ;; Lexicographic comparison on two items.
(define (item<? i1 i2) (define (item<? i1 i2)
@ -99,13 +114,6 @@
;; --------------------- Grammar Symbols -------------------------- ;; --------------------- Grammar Symbols --------------------------
;; gram-sym = (make-term symbol int prec)
;; | (make-non-term symbol int)
;; Each term has a unique index 0 <= index < number of terms
;; Each non-term has a unique index 0 <= index < number of non-terms
(define-struct term (sym index prec) (make-inspector))
(define-struct non-term (sym index) (make-inspector))
(define (non-term<? nt1 nt2) (define (non-term<? nt1 nt2)
(< (non-term-index nt1) (non-term-index nt2))) (< (non-term-index nt1) (non-term-index nt2)))
@ -134,12 +142,6 @@
(else (else
(bitwise-ior (arithmetic-shift 1 (term-index (car terms))) (term-list->bit-vector (cdr terms)))))) (bitwise-ior (arithmetic-shift 1 (term-index (car terms))) (term-list->bit-vector (cdr terms))))))
;; ------------------------- Precedences ---------------------------
;; a precedence declaration. the sym should be 'left 'right or 'nonassoc
;; prec = (make-prec int sym)
;; | #f
(define-struct prec (num assoc) (make-inspector))
;; ------------------------- Grammar ------------------------------ ;; ------------------------- Grammar ------------------------------
@ -147,10 +149,12 @@
(class object% (class object%
(super-instantiate ()) (super-instantiate ())
;; prods: production list list ;; prods: production list list
;; where the nth element in the outermost list is the list of productions with the nth non-term as lhs ;; where there is one production list per non-term
(init prods) (init prods)
;; init-prods: production list
;; The productions parsing can start from
;; nullable-non-terms is indexed by the non-term-index and is true iff non-term is nullable ;; nullable-non-terms is indexed by the non-term-index and is true iff non-term is nullable
(init-field terms non-terms end-terms) (init-field init-prods terms non-terms end-terms)
;; list of all productions ;; list of all productions
(define all-prods (apply append prods)) (define all-prods (apply append prods))
@ -196,8 +200,7 @@
(define/public (get-prods-for-non-term nt) (define/public (get-prods-for-non-term nt)
(vector-ref nt->prods (non-term-index nt))) (vector-ref nt->prods (non-term-index nt)))
(define/public (get-prods) all-prods) (define/public (get-prods) all-prods)
(define/public (get-init-prod) (define/public (get-init-prods) init-prods)
(car (vector-ref nt->prods 0)))
(define/public (get-terms) terms) (define/public (get-terms) terms)
(define/public (get-non-terms) non-terms) (define/public (get-non-terms) non-terms)
@ -275,9 +278,4 @@
nullable))))))) nullable)))))))
;; ------------------------ Productions ---------------------------
;; production = (make-prod non-term (gram-sym vector) int prec syntax-object)
;; Each production has a unique index 0 <= index <= number of productions
(define-struct prod (lhs rhs index prec action) (make-inspector))
) )

@ -345,10 +345,13 @@
(let* ((starts (map (lambda (x) (make-non-term (gensym) #f)) start-syms)) (let* ((starts (map (lambda (x) (make-non-term (gensym) #f)) start-syms))
(end-non-terms (map (lambda (x) (make-non-term (gensym) #f)) start-syms)) (end-non-terms (map (lambda (x) (make-non-term (gensym) #f)) start-syms))
(parsed-prods (map parse-prods-for-nt (cdr (syntax->list prods)))) (parsed-prods (map parse-prods-for-nt (cdr (syntax->list prods))))
(start-prods
(map (lambda (start end-non-term)
(list (make-prod start (vector end-non-term) #f #f
(datum->syntax-object runtime `(lambda (x) x)))))
starts end-non-terms))
(prods (prods
`(,@(map (lambda (start end-non-term) `(,@start-prods
(list (make-prod start (vector end-non-term) #f #f #f)))
starts end-non-terms)
,@(map ,@(map
(lambda (end-nt start-sym) (lambda (end-nt start-sym)
(map (map
@ -368,6 +371,7 @@
(make-object grammar% (make-object grammar%
prods prods
(map car start-prods)
terms terms
(append starts (append end-non-terms non-terms)) (append starts (append end-non-terms non-terms))
(map (lambda (term-name) (map (lambda (term-name)

@ -226,7 +226,7 @@
;; list for each kernel ;; list for each kernel
(kernels (make-hash-table 'equal)) (kernels (make-hash-table 'equal))
(counter 1) (counter 0)
;; goto: LR1-item list -> LR1-item list list ;; goto: LR1-item list -> LR1-item list list
;; creates new kernels by moving the dot in each item in the ;; creates new kernels by moving the dot in each item in the
@ -331,12 +331,19 @@
(loop (add1 i))))))) (loop (add1 i)))))))
(else null)))))))) (else null))))))))
(start (list (make-item (send grammar get-init-prod) 0))) (starts
(startk (make-kernel start 0)) (map (lambda (init-prod) (list (make-item init-prod 0)))
(send grammar get-init-prods)))
(startk
(map (lambda (start)
(let ((k (make-kernel start counter)))
(hash-table-put! kernels start k)
(set! counter (add1 counter))
k))
starts))
(new-kernels (make-queue))) (new-kernels (make-queue)))
(hash-table-put! kernels start startk) (let loop ((old-kernels startk)
(let loop ((old-kernels (list startk))
(seen-kernels null)) (seen-kernels null))
(cond (cond
((and (empty-queue? new-kernels) (null? old-kernels)) ((and (empty-queue? new-kernels) (null? old-kernels))

@ -150,6 +150,7 @@
(with-syntax ((check-syntax-fix check-syntax-fix) (with-syntax ((check-syntax-fix check-syntax-fix)
(err error) (err error)
(ends end) (ends end)
(starts start)
(debug debug) (debug debug)
(table table) (table table)
(term-sym->index term-sym->index) (term-sym->index term-sym->index)
@ -158,7 +159,7 @@
(syntax (syntax
(begin (begin
check-syntax-fix check-syntax-fix
(parser-body debug err (quote ends) table term-sym->index actions src-pos))))))) (parser-body debug err (quote starts) (quote ends) table term-sym->index actions src-pos)))))))
(_ (_
(raise-syntax-error #f (raise-syntax-error #f
"parser must have the form (parser args ...)" "parser must have the form (parser args ...)"
@ -188,7 +189,7 @@
;; an accept, shift or reduce structure - or a #f. Except that we will encode ;; an accept, shift or reduce structure - or a #f. Except that we will encode
;; by changing (make-accept) -> 'accept, (make-shift i) -> i and ;; by changing (make-accept) -> 'accept, (make-shift i) -> i and
;; (make-reduce i1 i2 i3) -> #(i1 i2 i3) ;; (make-reduce i1 i2 i3) -> #(i1 i2 i3)
(define (parser-body debug err ends table term-sym->index actions src-pos) (define (parser-body debug err starts ends table term-sym->index actions src-pos)
(letrec ((input->token (letrec ((input->token
(if src-pos (if src-pos
(lambda (ip) (lambda (ip)
@ -341,5 +342,12 @@
(err #t (token-name tok) (token-value tok) (cadr ip) (caddr ip)) (err #t (token-name tok) (token-value tok) (cadr ip) (caddr ip))
(err #t (token-name tok) (token-value tok))) (err #t (token-name tok) (token-value tok)))
(parsing-loop (fix-error stack tok ip get-token) (get-token)))))))))) (parsing-loop (fix-error stack tok ip get-token) (get-token))))))))))
(make-parser 0))) (cond
((null? (cdr starts)) (make-parser 0))
(else
(let loop ((l starts)
(i 0))
(cond
((null? l) null)
(else (cons (make-parser i) (loop (cdr l) (add1 i))))))))))
) )
Loading…
Cancel
Save