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

Modernize cfg-parser from mzscheme to Racket libraries.

Browse Source 
original commit: 4ff4c677bd354cb1a26adf0c3e0e4de03a7a3939
tokens
Danny Yoo 12 years ago
parent f4d9e18360 d6f9d98289
commit 33ebcd7a78
5 changed files with 972 additions and 978 deletions
Show Stats Download Patch File Download Diff File

87
collects/algol60/cfg-parser.rkt
Unescape Escape View File

@ -1,4 +1,4 @@
#lang racket/base
;; This module implements a parser form like the parser-tools's ;; This module implements a parser form like the parser-tools's
;; `parser', except that it works on an arbitrary CFG (returning ;; `parser', except that it works on an arbitrary CFG (returning
;; the first sucecssful parse). ;; the first sucecssful parse).
@ -28,14 +28,13 @@
;; parser uses `parser' so that it doesn't have to know anything about ;; parser uses `parser' so that it doesn't have to know anything about
;; tokens. ;; tokens.
(module cfg-parser mzscheme
(require parser-tools/yacc (require parser-tools/yacc
parser-tools/lex parser-tools/lex)
mzlib/list
mzlib/etc) (require (for-syntax racket/base
(require-for-syntax syntax/boundmap syntax/boundmap
mzlib/list parser-tools/private-lex/token-syntax))
parser-tools/private-lex/token-syntax)
(provide cfg-parser) (provide cfg-parser)
@ -45,19 +44,19 @@
;; Represents the thread scheduler: ;; Represents the thread scheduler:
(define-struct tasks (active active-back waits multi-waits cache progress?)) (define-struct tasks (active active-back waits multi-waits cache progress?))
(define-for-syntax make-token-identifier-mapping make-hash-table) (define-for-syntax make-token-identifier-mapping make-hasheq)
(define-for-syntax token-identifier-mapping-get (define-for-syntax token-identifier-mapping-get
(case-lambda (case-lambda
[(t tok) [(t tok)
(hash-table-get t (syntax-e tok))] (hash-ref t (syntax-e tok))]
[(t tok fail) [(t tok fail)
(hash-table-get t (syntax-e tok) fail)])) (hash-ref t (syntax-e tok) fail)]))
(define-for-syntax token-identifier-mapping-put! (define-for-syntax token-identifier-mapping-put!
(lambda (t tok v) (lambda (t tok v)
(hash-table-put! t (syntax-e tok) v))) (hash-set! t (syntax-e tok) v)))
(define-for-syntax token-identifier-mapping-map (define-for-syntax token-identifier-mapping-map
(lambda (t f) (lambda (t f)
(hash-table-map t f))) (hash-map t f)))
;; Used to calculate information on the grammar, such as whether ;; Used to calculate information on the grammar, such as whether
;; a particular non-terminal is "simple" instead of recursively defined. ;; a particular non-terminal is "simple" instead of recursively defined.
@ -216,7 +215,7 @@
;; Starts a thread ;; Starts a thread
(define queue-task (define queue-task
(opt-lambda (tasks t [progress? #t]) (lambda (tasks t [progress? #t])
(make-tasks (tasks-active tasks) (make-tasks (tasks-active tasks)
(cons t (tasks-active-back tasks)) (cons t (tasks-active-back tasks))
(tasks-waits tasks) (tasks-waits tasks)
@ -226,7 +225,7 @@
;; Reports an answer to a waiting thread: ;; Reports an answer to a waiting thread:
(define (report-answer answer-key max-depth tasks val) (define (report-answer answer-key max-depth tasks val)
(let ([v (hash-table-get (tasks-waits tasks) answer-key (lambda () #f))]) (let ([v (hash-ref (tasks-waits tasks) answer-key (lambda () #f))])
(if v (if v
(let ([tasks (make-tasks (cons (v val) (let ([tasks (make-tasks (cons (v val)
(tasks-active tasks)) (tasks-active tasks))
@ -235,7 +234,7 @@
(tasks-multi-waits tasks) (tasks-multi-waits tasks)
(tasks-cache tasks) (tasks-cache tasks)
#t)]) #t)])
(hash-table-remove! (tasks-waits tasks) answer-key) (hash-remove! (tasks-waits tasks) answer-key)
(swap-task max-depth tasks)) (swap-task max-depth tasks))
;; We have an answer ready too fast; wait ;; We have an answer ready too fast; wait
(swap-task max-depth (swap-task max-depth
@ -246,8 +245,8 @@
;; Reports an answer to multiple waiting threads: ;; Reports an answer to multiple waiting threads:
(define (report-answer-all answer-key max-depth tasks val k) (define (report-answer-all answer-key max-depth tasks val k)
(let ([v (hash-table-get (tasks-multi-waits tasks) answer-key (lambda () null))]) (let ([v (hash-ref (tasks-multi-waits tasks) answer-key (lambda () null))])
(hash-table-remove! (tasks-multi-waits tasks) answer-key) (hash-remove! (tasks-multi-waits tasks) answer-key)
(let ([tasks (make-tasks (append (map (lambda (a) (a val)) v) (let ([tasks (make-tasks (append (map (lambda (a) (a val)) v)
(tasks-active tasks)) (tasks-active tasks))
(tasks-active-back tasks) (tasks-active-back tasks)
@ -270,10 +269,10 @@
(success-k val stream depth max-depth tasks next-k))) (success-k val stream depth max-depth tasks next-k)))
(deadlock-k max-depth tasks))))]) (deadlock-k max-depth tasks))))])
(if multi? (if multi?
(hash-table-put! (tasks-multi-waits tasks) answer-key (hash-set! (tasks-multi-waits tasks) answer-key
(cons wait (hash-table-get (tasks-multi-waits tasks) answer-key (cons wait (hash-ref (tasks-multi-waits tasks) answer-key
(lambda () null)))) (lambda () null))))
(hash-table-put! (tasks-waits tasks) answer-key wait)) (hash-set! (tasks-waits tasks) answer-key wait))
(let ([tasks (make-tasks (tasks-active tasks) (let ([tasks (make-tasks (tasks-active tasks)
(tasks-active-back tasks) (tasks-active-back tasks)
(tasks-waits tasks) (tasks-waits tasks)
@ -295,17 +294,17 @@
(tasks-cache tasks) (tasks-cache tasks)
#f)) #f))
;; No progress, so issue failure for all multi-waits ;; No progress, so issue failure for all multi-waits
(if (zero? (hash-table-count (tasks-multi-waits tasks))) (if (zero? (hash-count (tasks-multi-waits tasks)))
(error 'swap-task "Deadlock") (error 'swap-task "Deadlock")
(swap-task max-depth (swap-task max-depth
(make-tasks (apply (make-tasks (apply
append append
(hash-table-map (tasks-multi-waits tasks) (hash-map (tasks-multi-waits tasks)
(lambda (k l) (lambda (k l)
(map (lambda (v) (v #f)) l)))) (map (lambda (v) (v #f)) l))))
(tasks-active-back tasks) (tasks-active-back tasks)
(tasks-waits tasks) (tasks-waits tasks)
(make-hash-table) (make-hasheq)
(tasks-cache tasks) (tasks-cache tasks)
#t)))) #t))))
(let ([t (car (tasks-active tasks))] (let ([t (car (tasks-active tasks))]
@ -338,14 +337,14 @@
#`(success-k #,handle stream depth max-depth tasks #`(success-k #,handle stream depth max-depth tasks
(lambda (success-k fail-k max-depth tasks) (lambda (success-k fail-k max-depth tasks)
(fail-k max-depth tasks))) (fail-k max-depth tasks)))
(let ([id (datum->syntax-object (car pat) (let ([id (datum->syntax (car pat)
(string->symbol (format "$~a" pos)))] (string->symbol (format "$~a" pos)))]
[id-start-pos (datum->syntax-object (car pat) [id-start-pos (datum->syntax (car pat)
(string->symbol (format "$~a-start-pos" pos)))] (string->symbol (format "$~a-start-pos" pos)))]
[id-end-pos (datum->syntax-object (car pat) [id-end-pos (datum->syntax (car pat)
(string->symbol (format "$~a-end-pos" pos)))] (string->symbol (format "$~a-end-pos" pos)))]
[n-end-pos (and (null? (cdr pat)) [n-end-pos (and (null? (cdr pat))
(datum->syntax-object (car pat) '$n-end-pos))]) (datum->syntax (car pat) '$n-end-pos))])
(cond (cond
[(bound-identifier-mapping-get nts (car pat) (lambda () #f)) [(bound-identifier-mapping-get nts (car pat) (lambda () #f))
;; Match non-termimal ;; Match non-termimal
@ -416,13 +415,13 @@
[old-stream stream]) [old-stream stream])
#;(printf "Loop ~a\n" table-key) #;(printf "Loop ~a\n" table-key)
(cond (cond
[(hash-table-get (tasks-cache tasks) table-key (lambda () #f)) [(hash-ref (tasks-cache tasks) table-key (lambda () #f))
=> (lambda (result) => (lambda (result)
#;(printf "Reuse ~a\n" table-key) #;(printf "Reuse ~a\n" table-key)
(result success-k fail-k max-depth tasks))] (result success-k fail-k max-depth tasks))]
[else [else
#;(printf "Try ~a ~a\n" table-key (map tok-name stream)) #;(printf "Try ~a ~a\n" table-key (map tok-name stream))
(hash-table-put! (tasks-cache tasks) table-key (hash-set! (tasks-cache tasks) table-key
(lambda (success-k fail-k max-depth tasks) (lambda (success-k fail-k max-depth tasks)
#;(printf "Wait ~a ~a\n" table-key answer-key) #;(printf "Wait ~a ~a\n" table-key answer-key)
(wait-for-answer #t max-depth tasks answer-key success-k fail-k (wait-for-answer #t max-depth tasks answer-key success-k fail-k
@ -436,7 +435,7 @@
;; Check whether we already have a result that consumed the same amount: ;; Check whether we already have a result that consumed the same amount:
(let ([result-key (vector #f key old-depth depth)]) (let ([result-key (vector #f key old-depth depth)])
(cond (cond
[(hash-table-get (tasks-cache tasks) result-key (lambda () #f)) [(hash-ref (tasks-cache tasks) result-key (lambda () #f))
;; Go for the next-result ;; Go for the next-result
(result-loop max-depth (result-loop max-depth
tasks tasks
@ -456,8 +455,8 @@
tasks tasks
(lambda (end max-depth tasks success-k fail-k) (lambda (end max-depth tasks success-k fail-k)
(next-k success-k fail-k max-depth tasks))))]) (next-k success-k fail-k max-depth tasks))))])
(hash-table-put! (tasks-cache tasks) result-key #t) (hash-set! (tasks-cache tasks) result-key #t)
(hash-table-put! (tasks-cache tasks) table-key (hash-set! (tasks-cache tasks) table-key
(lambda (success-k fail-k max-depth tasks) (lambda (success-k fail-k max-depth tasks)
(success-k val stream depth max-depth tasks next-k))) (success-k val stream depth max-depth tasks next-k)))
(report-answer-all answer-key (report-answer-all answer-key
@ -469,7 +468,7 @@
[new-fail-k [new-fail-k
(lambda (max-depth tasks) (lambda (max-depth tasks)
#;(printf "Failure ~a\n" table-key) #;(printf "Failure ~a\n" table-key)
(hash-table-put! (tasks-cache tasks) table-key (hash-set! (tasks-cache tasks) table-key
(lambda (success-k fail-k max-depth tasks) (lambda (success-k fail-k max-depth tasks)
(fail-k max-depth tasks))) (fail-k max-depth tasks)))
(report-answer-all answer-key (report-answer-all answer-key
@ -752,12 +751,15 @@
success-k success-k
fail-k fail-k
0 (make-tasks null null 0 (make-tasks null null
(make-hash-table) (make-hash-table) (make-hasheq) (make-hasheq)
(make-hash-table 'equal) #t)))))))))])) (make-hash) #t)))))))))]))
#|
;; Tests used during development
(module* test racket/base
(require (submod "..")
parser-tools/lex)
;; Tests used during development
(define-tokens non-terminals (PLUS MINUS STAR BAR COLON EOF)) (define-tokens non-terminals (PLUS MINUS STAR BAR COLON EOF))
(define lex (define lex
@ -767,8 +769,10 @@
["*" (token-STAR '*)] ["*" (token-STAR '*)]
["|" (token-BAR '||)] ["|" (token-BAR '||)]
[":" (token-COLON '|:|)] [":" (token-COLON '|:|)]
[whitespace (lex input-port)]
[(eof) (token-EOF 'eof)])) [(eof) (token-EOF 'eof)]))
(define parse (define parse
(cfg-parser (cfg-parser
(tokens non-terminals) (tokens non-terminals)
@ -792,11 +796,10 @@
(let ([p (open-input-string #;"+*|-|-*|+**" #;"-|+*|+**" (let ([p (open-input-string #;"+*|-|-*|+**" #;"-|+*|+**"
#;"+*|+**|-" #;"-|-*|-|-*" #;"+*|+**|-" #;"-|-*|-|-*"
#;"-|-*|-|-**|-|-*|-|-**" #;"-|-*|-|-**|-|-*|-|-**"
"-|-*|-|-**|-|-*|-|-***|-|-*|-|-**|-|-*|-|-****|-|-*|-|-**|-|-*|-|-***\ "-|-*|-|-**|-|-*|-|-***|-|-*|-|-**|-|-*|-|-****|-|-*|-|-**|-|-*|-|-***
|-|-*|-|-**|-|-*|-|-*****|-|-*|-|-**|-|-*|-|-***|-|-*|-|-**|-|-*|-|-****|\ |-|-*|-|-**|-|-*|-|-*****|-|-*|-|-**|-|-*|-|-***|-|-*|-|-**|-|-*|-|-****|
-|-*|-|-**|-|-*|-|-***|-|-*|-|-**|-|-*|-|-*****" -|-*|-|-**|-|-*|-|-***|-|-*|-|-**|-|-*|-|-*****"
;; This one fails: ;; This one fails:
#;"+*")]) #;"+*")])
(time (parse (lambda () (lex p)))))) (time (parse (lambda () (lex p))))))
|# (result))
)

4
collects/parser-tools/private-lex/token.rkt
Unescape Escape View File

@ -83,7 +83,7 @@
(define-syntax define-tokens (make-define-tokens #f)) (define-syntax define-tokens (make-define-tokens #f))
(define-syntax define-empty-tokens (make-define-tokens #t)) (define-syntax define-empty-tokens (make-define-tokens #t))
(define-struct position (offset line col)) (define-struct position (offset line col) #f)
(define-struct position-token (token start-pos end-pos)) (define-struct position-token (token start-pos end-pos) #f)
) )

9
collects/parser-tools/private-yacc/graph.rkt
Unescape Escape View File

@ -12,7 +12,7 @@
;; We use a hash-table to represent the result function 'a -> 'b set, so ;; We use a hash-table to represent the result function 'a -> 'b set, so
;; the values of type 'a must be comparable with eq?. ;; the values of type 'a must be comparable with eq?.
(define (digraph nodes edges f- union fail) (define (digraph nodes edges f- union fail)
(letrec ( (letrec [
;; Will map elements of 'a to 'b sets ;; Will map elements of 'a to 'b sets
(results (make-hash-table)) (results (make-hash-table))
(f (lambda (x) (hash-table-get results x fail))) (f (lambda (x) (hash-table-get results x fail)))
@ -51,7 +51,7 @@
(set-N p +inf.0) (set-N p +inf.0)
(hash-table-put! results p (f x)) (hash-table-put! results p (f x))
(if (not (eq? x p)) (if (not (eq? x p))
(loop (pop))))))))) (loop (pop))))))))]
(for-each (lambda (x) (for-each (lambda (x)
(if (= 0 (get-N x)) (if (= 0 (get-N x))
(traverse x))) (traverse x)))
@ -59,8 +59,3 @@
f)) f))
) )

8
collects/parser-tools/private-yacc/lalr.rkt
Unescape Escape View File

@ -134,7 +134,6 @@
(f (map follow l))) (f (map follow l)))
(apply bitwise-ior (cons 0 f)))))) (apply bitwise-ior (cons 0 f))))))
(define (print-DR dr a g) (define (print-DR dr a g)
(print-input-st-sym dr "DR" a g print-output-terms)) (print-input-st-sym dr "DR" a g print-output-terms))
(define (print-Read Read a g) (define (print-Read Read a g)
@ -230,7 +229,7 @@
;; Computes (f x) = (f- x) union Union{(f y) | y in (edges x)} ;; Computes (f x) = (f- x) union Union{(f y) | y in (edges x)}
;; A specialization of digraph in the file graph.rkt ;; A specialization of digraph in the file graph.rkt
(define (digraph-tk->terml nodes edges f- num-states) (define (digraph-tk->terml nodes edges f- num-states)
(letrec ( (letrec [
;; Will map elements of trans-key to term sets represented as bit vectors ;; Will map elements of trans-key to term sets represented as bit vectors
(results (init-tk-map num-states)) (results (init-tk-map num-states))
@ -269,13 +268,10 @@
(set-N p +inf.0) (set-N p +inf.0)
(set-f p (get-f x)) (set-f p (get-f x))
(unless (equal? x p) (unless (equal? x p)
(loop (pop))))))))) (loop (pop))))))))]
(for-each (lambda (x) (for-each (lambda (x)
(when (= 0 (get-N x)) (when (= 0 (get-N x))
(traverse x))) (traverse x)))
nodes) nodes)
get-f)) get-f))
) )

Write Preview
Loading…
Cancel
Save