mbutterick
/
br-parser-tools
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

*** empty log message ***

Browse Source 
original commit: 523537d7a5a24def6e889fa25a050239d23915c5
tokens
Scott Owens 23 years ago
parent 024d9d45cf
commit f00785e838
2 changed files with 34 additions and 34 deletions
Show Stats Download Patch File Download Diff File

56
collects/parser-tools/private-yacc/input-file-parser.ss
Unescape Escape View File

@ -161,14 +161,6 @@
nts))) nts)))
(syntax->list (syntax (non-term ...)))) (syntax->list (syntax (non-term ...))))
(if (not (memq start-sym
(syntax-object->datum (syntax (non-term ...)))))
(raise-syntax-error
'parser-start
(format "Start symbol ~a not defined as a non-terminal"
start-sym)
start))
(let ((dup (duplicate-list? (syntax-object->datum (let ((dup (duplicate-list? (syntax-object->datum
(syntax (non-term ...)))))) (syntax (non-term ...))))))
(if dup (if dup
@ -342,20 +334,21 @@
(syntax-case prods-so () (syntax-case prods-so ()
((nt productions ...) ((nt productions ...)
(> (length (syntax->list (syntax (productions ...)))) 0) (> (length (syntax->list (syntax (productions ...)))) 0)
(let* ((prods (syntax-e prods-so)) (let ((nt (hash-table-get
(nt (hash-table-get non-term-table non-term-table
(syntax-e (car prods))))) (syntax-object->datum (syntax nt)))))
(map (lambda (p) (parse-prod+action nt p)) (map (lambda (p) (parse-prod+action nt p))
(cdr prods)))) (syntax->list (syntax (productions ...))))))
(_ (_
(raise-syntax-error (raise-syntax-error
'parser-productions 'parser-productions
"A production for a non-terminal must be (non-term right-hand-side ...) with at least 1 right hand side" "A production for a non-terminal must be (non-term right-hand-side ...) with at least 1 right hand side"
prods-so)))))) prods-so))))))
(set! counter 0) (set! counter 1)
(let* ((start (make-non-term (gensym) 0)) (let* ((start (make-non-term (gensym) 0))
(end-non-term (make-non-term (gensym) 1)) (end-non-term (make-non-term (gensym) 1))
(parsed-prods (map parse-prods-for-nt (cdr (syntax->list prods))))
(prods (prods
`((,(make-prod start (vector end-non-term) 0 #f #f)) `((,(make-prod start (vector end-non-term) 0 #f #f))
,(map ,(map
@ -365,29 +358,36 @@
(vector (vector
(hash-table-get non-term-table start-sym) (hash-table-get non-term-table start-sym)
(hash-table-get term-table end)) (hash-table-get term-table end))
counter 1
#f #f
(datum->syntax-object (datum->syntax-object
runtime runtime
`(lambda (x) x)))) `(lambda (x) x))))
end-terms) end-terms)
,@(map parse-prods-for-nt (cdr (syntax->list prods))))) ,@parsed-prods))
(nulls (nullable (apply append prods) (nulls (nullable (apply append prods)
(+ 2 (length non-terms))))) (+ 2 (length non-terms)))))
; (printf "nullable: {~a}~n~n" (if (not (memq start-sym list-of-non-terms))
; (apply string-append (raise-syntax-error
; (let loop ((i 0)) 'parser-start
; (cond (format "Start symbol ~a not defined as a non-terminal"
; ((>= i (vector-length nulls)) null) start-sym)
; ((vector-ref nulls i) start))
; (cons
; (format "~a" (printf "nullable: {~a}~n~n"
; (gram-sym-symbol (apply string-append
; (list-ref (cons start non-terms) i))) (let loop ((i 0))
; (loop (add1 i)))) (cond
; (else (loop (add1 i))))))) ((>= i (vector-length nulls)) null)
((vector-ref nulls i)
(cons
(format "~a "
(gram-sym-symbol
(list-ref (cons start (cons end-non-term non-terms)) i)))
(loop (add1 i))))
(else (loop (add1 i)))))))
(make-grammar (make-grammar
(list->vector prods) (list->vector prods)
(apply append prods) (apply append prods)

12
collects/parser-tools/private-yacc/parser-builder.ss
Unescape Escape View File

@ -75,10 +75,10 @@
(let ((a (find-action stack 'error))) (let ((a (find-action stack 'error)))
(cond (cond
((shift? a) ((shift? a)
;; (printf "shift:~a~n" (shift-state a)) (printf "shift:~a~n" (shift-state a))
(set! stack (cons (shift-state a) (cons #f stack)))) (set! stack (cons (shift-state a) (cons #f stack))))
(else (else
;; (printf "discard-state:~a~n" (car stack)) (printf "discard-state:~a~n" (car stack))
(cond (cond
((< (length stack) 3) ((< (length stack) 3)
(printf "Unable to shift error token~n") (printf "Unable to shift error token~n")
@ -90,7 +90,7 @@
(let ((a (find-action stack ip))) (let ((a (find-action stack ip)))
(cond (cond
((shift? a) ((shift? a)
;; (printf "shift:~a~n" (shift-state a)) (printf "shift:~a~n" (shift-state a))
(cons (shift-state a) (cons (shift-state a)
(cons (if (token? ip) (cons (if (token? ip)
(token-value ip) (token-value ip)
@ -122,14 +122,14 @@
(let ((action (find-action stack ip))) (let ((action (find-action stack ip)))
(cond (cond
((shift? action) ((shift? action)
;; (printf "shift:~a~n" (shift-state action)) (printf "shift:~a~n" (shift-state action))
(let ((val (if (token? ip) (let ((val (if (token? ip)
(token-value ip) (token-value ip)
#f))) #f)))
(loop (cons (shift-state action) (cons val stack)) (loop (cons (shift-state action) (cons val stack))
(get-token)))) (get-token))))
((reduce? action) ((reduce? action)
;; (printf "reduce:~a~n" (reduce-prod-num action)) (printf "reduce:~a~n" (reduce-prod-num action))
(let-values (((new-stack args) (let-values (((new-stack args)
(reduce-stack stack (reduce-stack stack
(reduce-rhs-length action) (reduce-rhs-length action)
@ -144,7 +144,7 @@
new-stack)) new-stack))
ip)))) ip))))
((accept? action) ((accept? action)
;; (printf "accept~n") (printf "accept~n")
(cadr stack)) (cadr stack))
(else (else
(err) (err)

Write Preview
Loading…
Cancel
Save