Corrects stupid exponential bug (m^2 in a non-trivial m); corrects small repetitions in grammar
svn: r9257
This commit is contained in:
Kathy Gray
parent
db3c6931c8
commit
6222942f6f
|
|
@ -52,8 +52,12 @@
|
|||
[else #f]))]
|
||||
[possible-errors
|
||||
(lambda (matches)
|
||||
(filter res-possible-error
|
||||
(map (lambda (a) (if (repeat-res? a) (repeat-res-a a) a))
|
||||
(map (lambda (r)
|
||||
(or (and (res? r) (res-possible-error r))
|
||||
(and (repeat-res? r) (repeat-res-stop r))))
|
||||
(filter (lambda (r)
|
||||
(or (and (res? r) (res-possible-error r))
|
||||
(and (repeat-res? r) (fail-type? (repeat-res-stop r)))))
|
||||
matches)))]
|
||||
[result-a
|
||||
(lambda (res)
|
||||
|
|
@ -69,14 +73,13 @@
|
|||
[(and (pair? matched) (finished? (car matched))) (result-a (car matched))]
|
||||
[(pair? matched) (loop (cdr matched))]
|
||||
[(and matched (finished? matched)) (result-a matched)]
|
||||
[(or (null? matched) matched)
|
||||
(loop ((if (lazy-choice? result) next-choice next-opt) result))]
|
||||
[(or (null? matched) matched) (loop (next-opt result))]
|
||||
[else
|
||||
(let ([p-errors (possible-errors (lazy-opts-matches result))])
|
||||
(cond
|
||||
[(pair? p-errors)
|
||||
(let ([fails (cons (lazy-opts-errors result)
|
||||
(map res-possible-error p-errors))])
|
||||
(let ([fails (cons (lazy-opts-errors result) p-errors)])
|
||||
#;(printf "~nfails ~a~n~n" fails)
|
||||
(fail-type->message
|
||||
(make-options-fail (rank-choice (map fail-type-chance fails))
|
||||
#f
|
||||
|
|
@ -88,7 +91,7 @@
|
|||
[(null? p-errors)
|
||||
(fail-type->message (lazy-opts-errors result))]))])))]
|
||||
[(or (choice-res? result) (pair? result))
|
||||
(printf "choice-res or pair? ~a~n" result)
|
||||
#;(printf "choice-res or pair? ~a~n" result)
|
||||
(let* ([options (if (choice-res? result) (choice-res-matches result) result)]
|
||||
[finished-options (filter (lambda (o)
|
||||
(cond [(res? o)
|
||||
|
|
@ -132,8 +135,6 @@
|
|||
(not (null? possible-errors)))
|
||||
(let ([fails (cons (choice-res-errors result)
|
||||
(map res-possible-error possible-errors))])
|
||||
#;(printf "we are gonna call fail-type->message ~a ~n" fails)
|
||||
;uncomment printf, stop the loop, get the error... wtf
|
||||
(fail-type->message
|
||||
(make-options-fail (rank-choice (map fail-type-chance fails))
|
||||
#f
|
||||
|
|
|
|||
|
|
@ -128,7 +128,7 @@
|
|||
[my-error (sequence-error-gen name sequence-length)]
|
||||
[my-walker (seq-walker id-position name my-error)])
|
||||
(opt-lambda (input [last-src (list 1 0 1 0)] [alts 1])
|
||||
(unless (eq? input return-name) (printf "seq ~a~n" name))
|
||||
#;(unless (eq? input return-name) (printf "seq ~a~n" name))
|
||||
(cond
|
||||
[(eq? input return-name) name]
|
||||
[(weak-map-get memo-table input #f)
|
||||
|
|
@ -144,7 +144,7 @@
|
|||
[(pair? pre-build-ans) (map builder pre-build-ans)]
|
||||
[else pre-build-ans])])
|
||||
(weak-map-put! memo-table input ans)
|
||||
(printf "sequence ~a returning ~n" name)
|
||||
#;(printf "sequence ~a returning ~n" name)
|
||||
#;(printf "answer is ~a ~n" ans)
|
||||
ans)])))))
|
||||
|
||||
|
|
@ -214,7 +214,7 @@
|
|||
(lazy-opts-errors rsts)
|
||||
(map (lambda (thunk)
|
||||
(lambda ()
|
||||
(let ([ans (next-choice rsts)])
|
||||
(let ([ans (next-opt rsts)])
|
||||
(and ans (next-res old-answer new-id old-used tok ans)))))
|
||||
(lazy-opts-thunks rsts))
|
||||
(lazy-choice-name rsts))]
|
||||
|
|
@ -231,14 +231,14 @@
|
|||
(cond
|
||||
[(null? subs) (error 'end-of-subs)]
|
||||
[(null? next-preds)
|
||||
(printf "seq-walker called: last case, ~a case of ~a ~n"
|
||||
#;(printf "seq-walker called: last case, ~a case of ~a ~n"
|
||||
seq-name (curr-pred return-name))
|
||||
(build-error (curr-pred input last-src)
|
||||
(lambda () (previous? input))
|
||||
(previous? return-name) #f
|
||||
look-back look-back-ref used curr-id seen alts last-src)]
|
||||
[else
|
||||
(printf "seq-walker called: else case, ~a case of ~a ~ath case ~n"
|
||||
#;(printf "seq-walker called: else case, ~a case of ~a ~ath case ~n"
|
||||
seq-name (curr-pred return-name) (length seen))
|
||||
(let ([fst (curr-pred input last-src)])
|
||||
(cond
|
||||
|
|
@ -286,7 +286,7 @@
|
|||
(map
|
||||
(lambda (thunked)
|
||||
(lambda ()
|
||||
(let ([res (next-choice fst)])
|
||||
(let ([res (next-opt fst)])
|
||||
(if res
|
||||
(next-c res)
|
||||
(begin (set-lazy-opts-thunks! opt-r null) #f)))))
|
||||
|
|
@ -346,8 +346,8 @@
|
|||
(rank-choice (map fail-type-used fails))
|
||||
(rank-choice (map fail-type-may-use fails)) fails)))]
|
||||
[(and (null? correct-rsts) (lazy-choice? fst) (not (null? (lazy-opts-thunks fst))))
|
||||
(let loop ([next-res (next-choice fst)])
|
||||
(when next-res (loop (next-choice fst))))]
|
||||
(let loop ([next-res (next-opt fst)])
|
||||
(when next-res (loop (next-opt fst))))]
|
||||
[else correct-rsts]))]
|
||||
[else (error 'here3)]))])))])
|
||||
walker))
|
||||
|
|
@ -629,7 +629,7 @@
|
|||
(make-repeat-res (make-res null null (repeat-name) "" 0 #f #f) 'out-of-input)]
|
||||
[else
|
||||
(let ([this-res (sub curr-input curr-src)])
|
||||
(printf "Repeat of ~a called it's repeated entity ~n" (repeat-name))
|
||||
#;(printf "Repeat of ~a called it's repeated entity ~n" (repeat-name))
|
||||
(cond
|
||||
[(and (res? this-res) (res-a this-res))
|
||||
#;(printf "loop again case for ~a~n" (repeat-name))
|
||||
|
|
@ -653,6 +653,20 @@
|
|||
#;(printf "repeat-res case of ~a~n" repeat-name)
|
||||
(process-rest (repeat-res-a this-res)
|
||||
(res-rest (repeat-res-a this-res)))]
|
||||
[(lazy-opts? this-res)
|
||||
(let ([process (lambda (res)
|
||||
(cond [(res? res)
|
||||
(process-rest res (loop (res-rest res) (update-src (res-rest res) curr-src)))]
|
||||
[(repeat-res? res)
|
||||
(process-rest (repeat-res-a res) (res-rest (repeat-res-a res)))]
|
||||
[else (error 'repeat-greedy-loop (format "Internal error, given ~a" res))]))])
|
||||
(update-lazy-opts this-res
|
||||
(map process (lazy-opts-matches this-res))
|
||||
(map (lambda (t)
|
||||
(lambda ()
|
||||
(let ([next-res (next-opt this-res)])
|
||||
(and next-res (process next-res)))))
|
||||
(lazy-opts-thunks this-res))))]
|
||||
[(or (choice-res? this-res) (pair? this-res))
|
||||
(let ([list-of-answer
|
||||
(if (choice-res? this-res) (choice-res-matches this-res) (flatten this-res))])
|
||||
|
|
@ -680,7 +694,7 @@
|
|||
ans)]))))
|
||||
|
||||
;choice: [list [[list 'a ] -> result]] name -> result
|
||||
(define (choice2 opt-list name)
|
||||
(define (choice opt-list name)
|
||||
(let ([memo-table (make-weak-map)]
|
||||
[num-choices (length opt-list)]
|
||||
[choice-names (lambda () (map (lambda (o) (o return-name)) opt-list))])
|
||||
|
|
@ -732,12 +746,12 @@
|
|||
(weak-map-put! memo-table input ans) ans)])))))
|
||||
|
||||
;choice: [list [[list 'a ] -> result]] name -> result
|
||||
(define (choice opt-list name)
|
||||
(define (choice2 opt-list name)
|
||||
(let ([memo-table (make-weak-map)]
|
||||
[num-choices (length opt-list)]
|
||||
[choice-names (lambda () (map (lambda (o) (o return-name)) opt-list))])
|
||||
(opt-lambda (input [last-src (list 0 0 0 0)] [alts 1])
|
||||
(unless (eq? input return-name) (printf "choice ~a~n" name))
|
||||
#;(unless (eq? input return-name) (printf "choice ~a~n" name))
|
||||
#;(printf "possible options are ~a~n" choice-names)
|
||||
(let ([sub-opts (sub1 (+ alts num-choices))])
|
||||
(cond
|
||||
|
|
@ -759,10 +773,10 @@
|
|||
null)]
|
||||
[initial-ans (make-lazy-choice null initial-fail options name)]
|
||||
[ans
|
||||
(if (next-choice initial-ans)
|
||||
(if (next-opt initial-ans)
|
||||
initial-ans
|
||||
(fail-res input (lazy-opts-errors initial-ans)))])
|
||||
(printf "choice ~a is returning options were ~a, answer is ~a ~n" name (choice-names) ans)
|
||||
#;(printf "choice ~a is returning options were ~a, answer is ~a ~n" name (choice-names) ans)
|
||||
(weak-map-put! memo-table input ans) ans)])))))
|
||||
|
||||
(define (flatten lst)
|
||||
|
|
@ -840,14 +854,12 @@
|
|||
(- (position-offset new-end) (third src))))
|
||||
|
||||
(define (repeat op)
|
||||
(letrec ([name (lambda () "temp") #;(lambda () (string-append "any number of " (op return-name)))]
|
||||
[r* (choice (list op
|
||||
(seq (list op
|
||||
(opt-lambda (x [s (list 0 1 0 1)] [o 1]) (r* x s o)))
|
||||
(lambda (list-args) list-args #;(cons (car list-args) (cadr list-args)))
|
||||
(name))
|
||||
(seq null (lambda (x) null) return-name))
|
||||
(name))])
|
||||
(letrec ([name (lambda () (string-append "any number of " (op return-name)))]
|
||||
[r* (opt-lambda (x [s (list 0 1 0 1)] [o 1])
|
||||
((choice (list #;op
|
||||
(seq (list op r*) (lambda (list-args) list-args) (name))
|
||||
(seq null (lambda (x) null) "epsilon"))
|
||||
(name)) x s o))])
|
||||
r*))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@
|
|||
(let* ([name (fail-type-name fail-type)]
|
||||
[a (a/an name)]
|
||||
[msg (lambda (m) (make-err m (fail-type-src fail-type)))])
|
||||
(printf "fail-type->message ~a~n" fail-type)
|
||||
#;(printf "fail-type->message ~a~n" fail-type)
|
||||
(cond
|
||||
[(terminal-fail? fail-type)
|
||||
(collapse-message
|
||||
|
|
|
|||
|
|
@ -1,9 +1,6 @@
|
|||
(module structs scheme/base
|
||||
|
||||
(provide (except-out (all-defined-out)
|
||||
set-choice-fail-messages!
|
||||
set-lazy-opts-matches!)
|
||||
)
|
||||
(provide (all-defined-out))
|
||||
|
||||
(require parser-tools/lex)
|
||||
|
||||
|
|
@ -41,59 +38,55 @@
|
|||
;(make-lazy-choice (listof res) fail-type (listof (_ -> res)) string)
|
||||
(define-struct (lazy-choice lazy-opts) (name) #:transparent)
|
||||
|
||||
(define (update-choice-errors failc mss)
|
||||
(set-choice-fail-messages! failc (cons mss (choice-fail-messages failc)))
|
||||
(define (update-lazy-errors failc mss)
|
||||
(set-fail-type-chance! failc (max (fail-type-chance failc) (fail-type-chance mss)))
|
||||
(set-fail-type-used! failc (max (fail-type-used failc) (fail-type-used mss)))
|
||||
(set-fail-type-may-use! failc (max (fail-type-may-use failc) (fail-type-may-use mss))))
|
||||
(define (update-opt-errors failc mss)
|
||||
(set-options-fail-opts! failc (cons mss (options-fail-opts failc)))
|
||||
(set-fail-type-chance! failc (max (fail-type-chance failc) (fail-type-chance mss)))
|
||||
(set-fail-type-used! failc (max (fail-type-used failc) (fail-type-used mss)))
|
||||
(set-fail-type-may-use! failc (max (fail-type-may-use failc) (fail-type-may-use mss))))
|
||||
|
||||
(define (make-force thunks set-thunks matches set-matches update-errors errors)
|
||||
(set-fail-type-may-use! failc (max (fail-type-may-use failc) (fail-type-may-use mss)))
|
||||
(if (choice-fail? failc)
|
||||
(set-choice-fail-messages! failc (cons mss (choice-fail-messages failc)))
|
||||
(set-options-fail-opts! failc (cons mss (options-fail-opts failc)))))
|
||||
|
||||
|
||||
(define (next-opt lc)
|
||||
(letrec ([next
|
||||
(lambda (lc update-errors)
|
||||
(printf "next-opt ~a~n" lc)
|
||||
#;(printf "next-opt ~a~n" lc)
|
||||
(cond
|
||||
[(null? (thunks lc)) #f]
|
||||
[(null? (lazy-opts-thunks lc)) #f]
|
||||
[else
|
||||
(let ([curr-res ((car (thunks lc)))])
|
||||
(unless (null? (thunks lc)) (set-thunks lc (cdr (thunks lc))))
|
||||
(let ([curr-res ((car (lazy-opts-thunks lc)))])
|
||||
(unless (null? (lazy-opts-thunks lc))
|
||||
(set-lazy-opts-thunks! lc (cdr (lazy-opts-thunks lc))))
|
||||
(cond
|
||||
[(and (not curr-res) (not (null? (thunks lc)))) (next lc update-errors)]
|
||||
[(or (and (res? curr-res) (res-a curr-res))
|
||||
(repeat-res? curr-res))
|
||||
(set-matches lc (cons curr-res (matches lc)))
|
||||
[(and (not curr-res) (null? (lazy-opts-thunks lc))) curr-res]
|
||||
[(and (not curr-res) (not (null? (lazy-opts-thunks lc)))) (next lc update-errors)]
|
||||
[(or (and (res? curr-res) (res-a curr-res)) (repeat-res? curr-res))
|
||||
(set-lazy-opts-matches! lc (cons curr-res (lazy-opts-matches lc)))
|
||||
curr-res]
|
||||
[(lazy-opts? curr-res)
|
||||
(let* ([next-matches (map (lambda (m) (lambda () m)) (lazy-opts-matches curr-res))]
|
||||
[new-update (if (lazy-choice? curr-res) update-choice-errors update-opt-errors)]
|
||||
[remaining (map (lambda (t) (lambda () (next curr-res
|
||||
(lambda (_ msg)
|
||||
(new-update (errors curr-res) msg)))))
|
||||
[remaining (map (lambda (t)
|
||||
(lambda ()
|
||||
(next curr-res
|
||||
(lambda (_ msg) (update-lazy-errors (lazy-opts-errors curr-res) msg)))))
|
||||
(lazy-opts-thunks curr-res))])
|
||||
(set-thunks lc (append next-matches remaining (thunks lc)))
|
||||
(update-errors (errors lc) (lazy-opts-errors curr-res))
|
||||
(set-lazy-opts-thunks! lc (append next-matches remaining (lazy-opts-thunks lc)))
|
||||
(update-errors (lazy-opts-errors lc) (lazy-opts-errors curr-res))
|
||||
(next lc update-errors))]
|
||||
[(and (not curr-res) (null? (thunks lc))) curr-res]
|
||||
[else
|
||||
(update-errors (errors lc)
|
||||
(update-errors (lazy-opts-errors lc)
|
||||
(cond
|
||||
[(res? curr-res) (res-msg curr-res)]
|
||||
[else (error 'next (format "Internal error: failure other than res ~a" curr-res))]))
|
||||
(next lc update-errors)]))]))])
|
||||
(lambda (lc) (next lc update-errors))))
|
||||
(next lc update-lazy-errors)))
|
||||
|
||||
(define next-choice
|
||||
(make-force lazy-opts-thunks set-lazy-opts-thunks!
|
||||
lazy-opts-matches set-lazy-opts-matches!
|
||||
update-choice-errors lazy-opts-errors))
|
||||
(define next-opt
|
||||
(make-force lazy-opts-thunks set-lazy-opts-thunks!
|
||||
lazy-opts-matches set-lazy-opts-matches!
|
||||
update-opt-errors lazy-opts-errors))
|
||||
(define (update-lazy-opts old-opts matches thunks)
|
||||
(cond
|
||||
[(lazy-choice? old-opts)
|
||||
(make-lazy-choice matches (lazy-opts-errors old-opts) thunks (lazy-choice-name old-opts))]
|
||||
[(lazy-opts? old-opts)
|
||||
(make-lazy-opts matches (lazy-opts-errors old-opts) thunks)]))
|
||||
|
||||
(define (fail-res rst msg) (make-res #f rst msg "" 0 #f #f))
|
||||
|
||||
|
|
|
|||
|
|
@ -202,7 +202,7 @@
|
|||
(choose (base-type name) "type"))
|
||||
|
||||
(define (method-type base-t)
|
||||
(choice (list base-t voidT) "method return"))
|
||||
(choose (base-t voidT) "method return"))
|
||||
|
||||
(define (array-type base-t)
|
||||
(sequence (base-t (repeat (sequence (O_BRACKET C_BRACKET) id "array type"))) id "type"))
|
||||
|
|
@ -287,7 +287,7 @@
|
|||
[base (sequence (type (^ identifier)) id var-name)]
|
||||
[decl
|
||||
(cond
|
||||
[(and expr share-type?) (choose (s&e e base) var-name)]
|
||||
[(and expr share-type?) s&e #;(choose (s&e e base) var-name)]
|
||||
[share-type? s]
|
||||
[expr (choose (e base) var-name)]
|
||||
[else base])])
|
||||
|
|
@ -506,10 +506,10 @@
|
|||
(choose ((sequence (O_PAREN C_PAREN) id)
|
||||
(sequence (O_PAREN a C_PAREN) id)) "method parameter list")
|
||||
(sequence (O_PAREN C_PAREN) id "method parameter list"))]
|
||||
[full (sequence ((repeat m) ret (^ identifier) method-parms throws (comma-sep n "thrown types")) id "method signature")]
|
||||
[full-no-t (sequence ((repeat m) ret (^ identifier) method-parms) id "method signature")]
|
||||
[no-mods-t (sequence (ret (^ identifier) method-parms throws (comma-sep n "thrown types")) id "method signature")]
|
||||
[no-mods (sequence (ret (^ identifier) method-parms) id "method signature")])
|
||||
[full (sequence ((^ full-no-t) throws (comma-sep n "thrown types")) id "method signature")]
|
||||
[no-mods (sequence (ret (^ identifier) method-parms) id "method signature")]
|
||||
[no-mods-t (sequence ((^ no-mods) throws (comma-sep n "thrown types")) id "method signature")])
|
||||
(cond
|
||||
[(and m t?) (choose (full full-no-t) "method signature")]
|
||||
[m full-no-t]
|
||||
|
|
@ -546,12 +546,11 @@
|
|||
[m (sequence ((repeat modifier) interface (^ IDENTIFIER) O_BRACE body C_BRACE) id "interface definition")]
|
||||
[e (sequence (interface (^ IDENTIFIER) extends O_BRACE body C_BRACE) id "interface definition")]
|
||||
[always (sequence (interface (^ IDENTIFIER) O_BRACE body C_BRACE) id "interface definition")])
|
||||
(choice (cond
|
||||
[(and modifier extends) (list m&e m e always)]
|
||||
[modifier (list m always)]
|
||||
[extends (list e always)]
|
||||
[else (list always)])
|
||||
"interface definition")))
|
||||
(cond
|
||||
[(and modifier extends) (choose (m&e m) "interface definition")]
|
||||
[modifier m]
|
||||
[extends (choose (e always) "interface definition")]
|
||||
[else always])))
|
||||
|
||||
)
|
||||
|
||||
|
|
@ -594,7 +593,6 @@
|
|||
(define (top-member mems)
|
||||
(choice mems "class or interface"))
|
||||
|
||||
;Note -- should enfore name to be identifier.identifier instead of name
|
||||
(define import-dec
|
||||
(let ([name (sequence (identifier (repeat-greedy (sequence (PERIOD identifier) id "import name")))
|
||||
id "import name")])
|
||||
|
|
@ -608,17 +606,15 @@
|
|||
[i (sequence (import body) id "program")])
|
||||
(cond
|
||||
[(and package import)
|
||||
(choice (list p&i i ) "program")]
|
||||
(choose (p&i i) "program")]
|
||||
[package
|
||||
(choice (list p body) "program")]
|
||||
[import
|
||||
(choice (list i body) "program")]
|
||||
(choose (p body) "program")]
|
||||
[import i]
|
||||
[else body])))
|
||||
|
||||
)
|
||||
|
||||
;Remembered Unsupported Features
|
||||
;throws clause
|
||||
;strictfp
|
||||
;allowing static fields in interface
|
||||
|
||||
|
|
@ -664,16 +660,17 @@
|
|||
(define constructor (make-constructor #f (repeat-greedy init) (value+name-type prim-type)))
|
||||
|
||||
(define interface (interface-def #f #f
|
||||
(repeat-greedy
|
||||
(sequence (method-sig SEMI_COLON) id "method signature"))))
|
||||
(repeat (sequence (method-sig SEMI_COLON) id "method signature"))))
|
||||
|
||||
(define class
|
||||
(class-def #f #f (implements-dec identifier)
|
||||
(class-def #f #f
|
||||
(implements-dec identifier)
|
||||
(repeat (class-body (list field method constructor)))))
|
||||
|
||||
(define program
|
||||
(make-program #f (repeat import-dec)
|
||||
(repeat (top-member (list class interface)))))
|
||||
(make-program #f
|
||||
(repeat-greedy import-dec)
|
||||
(repeat-greedy (top-member (list class interface)))))
|
||||
|
||||
(define interact
|
||||
(choose (field statement expression) "interactive program"))
|
||||
|
|
@ -769,7 +766,8 @@
|
|||
|
||||
|
||||
(define program
|
||||
(make-program #f (repeat-greedy import-dec)
|
||||
(make-program #f
|
||||
(repeat-greedy import-dec)
|
||||
(repeat-greedy (choose (class interface) "class or interface"))))
|
||||
|
||||
(define interact
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user