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
;; `parser', except that it works on an arbitrary CFG (returning
;; the first sucecssful parse).
@ -28,14 +28,13 @@
;; parser uses `parser' so that it doesn't have to know anything about
;; tokens.
(module cfg-parser mzscheme
(require parser-tools/yacc
parser-tools/lex
mzlib/list
mzlib/etc)
(require-for-syntax syntax/boundmap
mzlib/list
parser-tools/private-lex/token-syntax)
parser-tools/lex)
(require (for-syntax racket/base
syntax/boundmap
parser-tools/private-lex/token-syntax))
(provide cfg-parser)
@ -45,19 +44,19 @@
;; Represents the thread scheduler:
(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
(case-lambda
[(t tok)
(hash-table-get t (syntax-e tok))]
(hash-ref t (syntax-e tok))]
[(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!
(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
(lambda (t f)
(hash-table-map t f)))
(hash-map t f)))
;; Used to calculate information on the grammar, such as whether
;; a particular non-terminal is "simple" instead of recursively defined.
@ -216,7 +215,7 @@
;; Starts a thread
(define queue-task
(opt-lambda (tasks t [progress? #t])
(lambda (tasks t [progress? #t])
(make-tasks (tasks-active tasks)
(cons t (tasks-active-back tasks))
(tasks-waits tasks)
@ -226,7 +225,7 @@
;; Reports an answer to a waiting thread:
(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
(let ([tasks (make-tasks (cons (v val)
(tasks-active tasks))
@ -235,7 +234,7 @@
(tasks-multi-waits tasks)
(tasks-cache tasks)
#t)])
(hash-table-remove! (tasks-waits tasks) answer-key)
(hash-remove! (tasks-waits tasks) answer-key)
(swap-task max-depth tasks))
;; We have an answer ready too fast; wait
(swap-task max-depth
@ -246,8 +245,8 @@
;; Reports an answer to multiple waiting threads:
(define (report-answer-all answer-key max-depth tasks val k)
(let ([v (hash-table-get (tasks-multi-waits tasks) answer-key (lambda () null))])
(hash-table-remove! (tasks-multi-waits tasks) answer-key)
(let ([v (hash-ref (tasks-multi-waits tasks) answer-key (lambda () null))])
(hash-remove! (tasks-multi-waits tasks) answer-key)
(let ([tasks (make-tasks (append (map (lambda (a) (a val)) v)
(tasks-active tasks))
(tasks-active-back tasks)
@ -270,10 +269,10 @@
(success-k val stream depth max-depth tasks next-k)))
(deadlock-k max-depth tasks))))])
(if multi?
(hash-table-put! (tasks-multi-waits tasks) answer-key
(cons wait (hash-table-get (tasks-multi-waits tasks) answer-key
(hash-set! (tasks-multi-waits tasks) answer-key
(cons wait (hash-ref (tasks-multi-waits tasks) answer-key
(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)
(tasks-active-back tasks)
(tasks-waits tasks)
@ -295,17 +294,17 @@
(tasks-cache tasks)
#f))
;; 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")
(swap-task max-depth
(make-tasks (apply
append
(hash-table-map (tasks-multi-waits tasks)
(hash-map (tasks-multi-waits tasks)
(lambda (k l)
(map (lambda (v) (v #f)) l))))
(tasks-active-back tasks)
(tasks-waits tasks)
(make-hash-table)
(make-hasheq)
(tasks-cache tasks)
#t))))
(let ([t (car (tasks-active tasks))]
@ -338,14 +337,14 @@
#`(success-k #,handle stream depth max-depth tasks
(lambda (success-k 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)))]
[id-start-pos (datum->syntax-object (car pat)
[id-start-pos (datum->syntax (car pat)
(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)))]
[n-end-pos (and (null? (cdr pat))
(datum->syntax-object (car pat) '$n-end-pos))])
(datum->syntax (car pat) '$n-end-pos))])
(cond
[(bound-identifier-mapping-get nts (car pat) (lambda () #f))
;; Match non-termimal
@ -416,13 +415,13 @@
[old-stream stream])
#;(printf "Loop ~a\n" table-key)
(cond
[(hash-table-get (tasks-cache tasks) table-key (lambda () #f))
[(hash-ref (tasks-cache tasks) table-key (lambda () #f))
=> (lambda (result)
#;(printf "Reuse ~a\n" table-key)
(result success-k fail-k max-depth tasks))]
[else
#;(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)
#;(printf "Wait ~a ~a\n" table-key answer-key)
(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:
(let ([result-key (vector #f key old-depth depth)])
(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
(result-loop max-depth
tasks
@ -456,8 +455,8 @@
tasks
(lambda (end max-depth tasks success-k fail-k)
(next-k success-k fail-k max-depth tasks))))])
(hash-table-put! (tasks-cache tasks) result-key #t)
(hash-table-put! (tasks-cache tasks) table-key
(hash-set! (tasks-cache tasks) result-key #t)
(hash-set! (tasks-cache tasks) table-key
(lambda (success-k fail-k max-depth tasks)
(success-k val stream depth max-depth tasks next-k)))
(report-answer-all answer-key
@ -469,7 +468,7 @@
[new-fail-k
(lambda (max-depth tasks)
#;(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)
(fail-k max-depth tasks)))
(report-answer-all answer-key
@ -752,12 +751,15 @@
success-k
fail-k
0 (make-tasks null null
(make-hash-table) (make-hash-table)
(make-hash-table 'equal) #t)))))))))]))
(make-hasheq) (make-hasheq)
(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 lex
@ -767,8 +769,10 @@
["*" (token-STAR '*)]
["|" (token-BAR '||)]
[":" (token-COLON '|:|)]
[whitespace (lex input-port)]
[(eof) (token-EOF 'eof)]))
(define parse
(cfg-parser
(tokens non-terminals)
@ -792,11 +796,10 @@
(let ([p (open-input-string #;"+*|-|-*|+**" #;"-|+*|+**"
#;"+*|+**|-" #;"-|-*|-|-*"
#;"-|-*|-|-**|-|-*|-|-**"
"-|-*|-|-**|-|-*|-|-***|-|-*|-|-**|-|-*|-|-****|-|-*|-|-**|-|-*|-|-***\
|-|-*|-|-**|-|-*|-|-*****|-|-*|-|-**|-|-*|-|-***|-|-*|-|-**|-|-*|-|-****|\
"-|-*|-|-**|-|-*|-|-***|-|-*|-|-**|-|-*|-|-****|-|-*|-|-**|-|-*|-|-***
|-|-*|-|-**|-|-*|-|-*****|-|-*|-|-**|-|-*|-|-***|-|-*|-|-**|-|-*|-|-****|
-|-*|-|-**|-|-*|-|-***|-|-*|-|-**|-|-*|-|-*****"
;; This one fails:
#;"+*")])
(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-empty-tokens (make-define-tokens #t))
(define-struct position (offset line col))
(define-struct position-token (token start-pos end-pos))
(define-struct position (offset line col) #f)
(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
;; the values of type 'a must be comparable with eq?.
(define (digraph nodes edges f- union fail)
(letrec (
(letrec [
;; Will map elements of 'a to 'b sets
(results (make-hash-table))
(f (lambda (x) (hash-table-get results x fail)))
@ -51,7 +51,7 @@
(set-N p +inf.0)
(hash-table-put! results p (f x))
(if (not (eq? x p))
(loop (pop)))))))))
(loop (pop))))))))]
(for-each (lambda (x)
(if (= 0 (get-N x))
(traverse x)))
@ -59,8 +59,3 @@
f))
)

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

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

Write Preview
Loading…
Cancel
Save