Removes the reliance of the combinator parser on the lazy language
svn: r8830
This commit is contained in:
Kathy Gray
parent
74f543f7ae
commit
0fa9e74dfc
|
|
@ -1,7 +1,8 @@
|
|||
(module combinator-parser lazy
|
||||
|
||||
(require mzlib/unit parser-tools/lex)
|
||||
(module combinator-parser scheme/base
|
||||
|
||||
(require scheme/list
|
||||
scheme/unit
|
||||
parser-tools/lex)
|
||||
(require "structs.scm" "parser-sigs.ss" "combinator.scm" "errors.scm")
|
||||
|
||||
(provide combinator-parser-tools@)
|
||||
|
|
@ -12,43 +13,43 @@
|
|||
|
||||
(define (sort-used reses)
|
||||
(sort reses
|
||||
(lambda (a b) (!!! (> (res-used a) (res-used b))))))
|
||||
(lambda (a b) (> (res-used a) (res-used b)))))
|
||||
(define (sort-repeats repeats)
|
||||
(sort repeats
|
||||
(lambda (a b) (!!! (> (res-used (repeat-res-a a))
|
||||
(res-used (repeat-res-a b)))))))
|
||||
(lambda (a b) (> (res-used (repeat-res-a a))
|
||||
(res-used (repeat-res-a b))))))
|
||||
|
||||
(define (parser start)
|
||||
(lambda (input file)
|
||||
(let* ([first-src (and src? (pair? input)
|
||||
(make-src-lst (position-token-start-pos (car input))
|
||||
(position-token-end-pos (car input))))]
|
||||
(position-token-end-pos (car input))))]
|
||||
[result (if first-src (start input first-src) (start input))]
|
||||
[out
|
||||
(cond
|
||||
[(and (res? result) (res-a result) (null? (res-rest result)))
|
||||
(car (res-a (!!! result)))]
|
||||
[(and (res? result) (res-a result) (!!! (res-possible-error result)))
|
||||
(fail-type->message (!!! (res-possible-error result)))]
|
||||
(car (res-a result))]
|
||||
[(and (res? result) (res-a result) (res-possible-error result))
|
||||
(fail-type->message (res-possible-error result))]
|
||||
[(and (res? result) (res-a result))
|
||||
(make-err
|
||||
(format "Found extraneous input after ~a, starting with ~a, at the end of ~a."
|
||||
(!!! (res-msg result))
|
||||
(input->output-name (!!! (car (res-rest result)))) input-type)
|
||||
(res-msg result)
|
||||
(input->output-name (car (res-rest result))) input-type)
|
||||
(and src?
|
||||
(make-src-lst (position-token-start-pos (!!! (car (res-rest result))))
|
||||
(position-token-end-pos (!!! (car (res-rest result)))))))]
|
||||
(make-src-lst (position-token-start-pos (car (res-rest result)))
|
||||
(position-token-end-pos (car (res-rest result))))))]
|
||||
[(res? result)
|
||||
(fail-type->message (res-msg (!!! result)))]
|
||||
(fail-type->message (res-msg result))]
|
||||
[(or (choice-res? result) (pair? result))
|
||||
#;(printf "choice-res or pair? ~a~n" (choice-res? result))
|
||||
(let* ([options (if (choice-res? result) (choice-res-matches result) result)]
|
||||
[finished-options (filter (lambda (o)
|
||||
(!!! (cond [(res? o)
|
||||
(and (not (null? (res-a o)))
|
||||
(null? (res-rest o)))]
|
||||
[(repeat-res? o)
|
||||
(eq? (repeat-res-stop o) 'out-of-input)])))
|
||||
(cond [(res? o)
|
||||
(and (not (null? (res-a o)))
|
||||
(null? (res-rest o)))]
|
||||
[(repeat-res? o)
|
||||
(eq? (repeat-res-stop o) 'out-of-input)]))
|
||||
options)]
|
||||
[possible-repeat-errors
|
||||
(filter (lambda (r) (and (repeat-res? r)
|
||||
|
|
@ -62,7 +63,7 @@
|
|||
(cond
|
||||
[(not (null? finished-options))
|
||||
#;(printf "finished an option~n")
|
||||
(let ([first-fo (!!! (car finished-options))])
|
||||
(let ([first-fo (car finished-options)])
|
||||
(car (cond
|
||||
[(res? first-fo) (res-a first-fo)]
|
||||
[(and (repeat-res? first-fo)
|
||||
|
|
@ -73,64 +74,64 @@
|
|||
(format "~a" first-fo))])))]
|
||||
#;[(not (null? possible-repeat-errors))
|
||||
(printf "possible-repeat error~n")
|
||||
(!!! (fail-type->message
|
||||
(!!! (car (repeat-res-stop
|
||||
(sort-repeats possible-repeat-errors))))))]
|
||||
(fail-type->message
|
||||
(car (repeat-res-stop
|
||||
(sort-repeats possible-repeat-errors))))]
|
||||
[(and (choice-res? result) (fail-type? (choice-res-errors result)))
|
||||
#;(printf "choice res and choice res errors ~n")
|
||||
(cond
|
||||
[(and (null? possible-repeat-errors)
|
||||
(null? possible-errors)) (!!! (fail-type->message (choice-res-errors result)))]
|
||||
(null? possible-errors)) (fail-type->message (choice-res-errors result))]
|
||||
[(or #;(not (null? possible-repeat-errors))
|
||||
(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
|
||||
(choice-res-name result)
|
||||
(rank-choice (map fail-type-used fails))
|
||||
(rank-choice (map fail-type-may-use fails))
|
||||
fails))))])]
|
||||
(fail-type->message
|
||||
(make-options-fail (rank-choice (map fail-type-chance fails))
|
||||
#f
|
||||
(choice-res-name result)
|
||||
(rank-choice (map fail-type-used fails))
|
||||
(rank-choice (map fail-type-may-use fails))
|
||||
fails)))])]
|
||||
[(not (null? possible-errors))
|
||||
;(printf "choice or pair fail~n")
|
||||
(!!! (fail-type->message
|
||||
(res-possible-error (!!! (car (sort-used possible-errors))))))]
|
||||
(fail-type->message
|
||||
(res-possible-error (car (sort-used possible-errors))))]
|
||||
[else
|
||||
#;(printf "result ~a~n" result)
|
||||
(let ([used-sort (sort-used options)])
|
||||
(if (and (choice-res? result)
|
||||
(choice-res-errors result))
|
||||
(!!! (fail-type->message (choice-res-errors result)))
|
||||
(fail-type->message (choice-res-errors result))
|
||||
(make-err
|
||||
(format "Found additional content after ~a, begining with '~a'."
|
||||
(!!! (res-msg (car used-sort)))
|
||||
(input->output-name (!!! (car (res-rest (car used-sort))))))
|
||||
(res-msg (car used-sort))
|
||||
(input->output-name (car (res-rest (car used-sort)))))
|
||||
(and src?
|
||||
(make-src-lst (position-token-start-pos
|
||||
(!!! (car (res-rest (car used-sort)))))
|
||||
(car (res-rest (car used-sort))))
|
||||
(position-token-end-pos
|
||||
(!!! (car (res-rest (car used-sort))))))))))]))]
|
||||
[(and (repeat-res? result) (eq? 'out-of-input (repeat-res-stop (!!! result))))
|
||||
(car (res-rest (car used-sort)))))))))]))]
|
||||
[(and (repeat-res? result) (eq? 'out-of-input (repeat-res-stop result)))
|
||||
(res-a (repeat-res-a result))]
|
||||
[(and (repeat-res? result) (fail-type? (repeat-res-stop (!!! result))))
|
||||
[(and (repeat-res? result) (fail-type? (repeat-res-stop result)))
|
||||
;(printf "repeat-fail~n")
|
||||
(!!! (fail-type->message (!!! (repeat-res-stop (!!! result)))))]
|
||||
(fail-type->message (repeat-res-stop result))]
|
||||
[else (error 'parser (format "Internal error: recieved unexpected input ~a"
|
||||
(!!! result)))])])
|
||||
result))])])
|
||||
(cond
|
||||
[(err? out)
|
||||
(make-err (!!! (err-msg out))
|
||||
(make-err (err-msg out)
|
||||
(if (err-src out)
|
||||
(list (!!! file)
|
||||
(!!! (first (err-src out)))
|
||||
(!!! (second (err-src out)))
|
||||
(!!! (third (err-src out)))
|
||||
(!!! (fourth (err-src out))))
|
||||
(list (!!! file) 1 0 1 0)))]
|
||||
[else (!!! out)]))))
|
||||
(list file
|
||||
(first (err-src out))
|
||||
(second (err-src out))
|
||||
(third (err-src out))
|
||||
(fourth (err-src out)))
|
||||
(list file 1 0 1 0)))]
|
||||
[else out]))))
|
||||
)
|
||||
|
||||
(define-unit rank-defaults@
|
||||
|
|
@ -144,7 +145,7 @@
|
|||
(define-unit out-struct@
|
||||
(import)
|
||||
(export out^)
|
||||
(define-struct err (msg src)))
|
||||
(define-struct err (msg src) #:mutable))
|
||||
|
||||
(define-compound-unit/infer combinator-parser@
|
||||
(import error-format-parameters^ language-format-parameters^ language-dictionary^)
|
||||
|
|
|
|||
|
|
@ -1,13 +1,14 @@
|
|||
(module combinator lazy
|
||||
(module combinator scheme/base
|
||||
|
||||
(require mzlib/unit
|
||||
(only mzlib/etc opt-lambda))
|
||||
(require scheme/unit
|
||||
scheme/list
|
||||
(only-in (lib "etc.ss") opt-lambda))
|
||||
|
||||
(require "structs.scm"
|
||||
"parser-sigs.ss"
|
||||
parser-tools/lex)
|
||||
|
||||
(provide (all-defined))
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define-unit combinators@
|
||||
(import error-format-parameters^ ranking-parameters^ language-dictionary^)
|
||||
|
|
@ -34,23 +35,15 @@
|
|||
(define terminal
|
||||
(opt-lambda (pred build name [spell? #f] [case? #f] [class? #f])
|
||||
(let* ([fail-str (string-append "failed " name)]
|
||||
[t-name
|
||||
(lambda (t) (if src? (token-name (position-token-token t)) (token-name t)))]
|
||||
[t-val
|
||||
(lambda (t) (if src? (token-value (position-token-token t)) (token-value t)))]
|
||||
[spell? (if spell? spell?
|
||||
[t-name (if src? (lambda (t) (token-name (position-token-token t))) token-name)]
|
||||
[t-val (if src? (lambda (t) (token-value (position-token-token t))) token-value)]
|
||||
[spell? (or spell?
|
||||
(lambda (token)
|
||||
(when (position-token? token) (set! token (position-token-token token)))
|
||||
(if (token-value token) (misspelled name (token-value token)) 0)))]
|
||||
[case? (if case? case?
|
||||
(if (t-val token) (misspelled name (t-val token)) 0)))]
|
||||
[case? (or case?
|
||||
(lambda (token)
|
||||
(when (position-token? token) (set! token (position-token-token token)))
|
||||
(and (token-value token)
|
||||
(misscap name (token-value token)))))]
|
||||
[class? (if class? class?
|
||||
(lambda (token)
|
||||
(when (position-token? token) (set! token (position-token-token token)))
|
||||
(missclass name (token-name token))))]
|
||||
(and (t-val token) (misscap name (t-val token)))))]
|
||||
[class? (or class? (lambda (token) (missclass name (t-name token))))]
|
||||
[make-fail
|
||||
(lambda (c n k i u)
|
||||
(make-terminal-fail c (if (and src? i)
|
||||
|
|
@ -67,39 +60,37 @@
|
|||
build)])
|
||||
|
||||
(opt-lambda (input [last-src (list 1 0 1 0)] [alts 1])
|
||||
#;(!!! (printf "terminal ~a~n" name))
|
||||
#;(!!! (printf "input ~a~n" (pair? input)))
|
||||
#;(!!! (printf "input ~a~n" (null? input)))
|
||||
#;(!!! (cond
|
||||
[(eq? input return-name)
|
||||
(printf "dummy given~n")]
|
||||
[(null? input) (printf "null given~n")]
|
||||
[else
|
||||
(let ([token (!!! ((!!! position-token-token) (!!! (car input))))])
|
||||
(!!! (printf "Look at token ~a~n" token))
|
||||
#;(!!! (printf "calling token-name: ~a~n" ((!!! token-name) token)))
|
||||
(!!! (printf "calling pred: ~a~n" (pred token)))
|
||||
#;(!!! (printf "called pred~n"))
|
||||
#;(!!! (printf "car of input ~a~n" (position-token-token (car input)))))]))
|
||||
#;(printf "terminal ~a~n" name)
|
||||
#;(printf "input ~a~n" (pair? input))
|
||||
#;(printf "input ~a~n" (null? input))
|
||||
#;(cond
|
||||
[(eq? input return-name)
|
||||
(printf "dummy given~n")]
|
||||
[(null? input) (printf "null given~n")]
|
||||
[else
|
||||
(let ([token (position-token-token (car input))])
|
||||
(printf "Look at token ~a~n" token)
|
||||
(printf "calling pred: ~a~n" (pred token)))])
|
||||
(cond
|
||||
[(eq? input return-name) name]
|
||||
[(null? input)
|
||||
(fail-res null (make-terminal-fail rank-end last-src name 0 0 'end #f))]
|
||||
[else
|
||||
(let* ([curr-input (car input)]
|
||||
[token (position-token-token curr-input)])
|
||||
[token (if src? (position-token-token curr-input) curr-input)])
|
||||
(cond
|
||||
[(pred token)
|
||||
(make-res (list (builder curr-input)) (cdr input) name
|
||||
(make-res (list (builder curr-input))
|
||||
(cdr input) name
|
||||
(value curr-input) 1 #f curr-input)]
|
||||
[else
|
||||
#;(!!! (printf "Incorrect input for ~a : ~a miscase? ~a misspell? ~a ~n" name
|
||||
(cond
|
||||
[(token-value token)
|
||||
(token-value token)]
|
||||
[else (token-name token)])
|
||||
(case? curr-input)
|
||||
(spell? curr-input)))
|
||||
#;(printf "Incorrect input for ~a : ~a miscase? ~a misspell? ~a ~n" name
|
||||
(cond
|
||||
[(token-value token)
|
||||
(token-value token)]
|
||||
[else (token-name token)])
|
||||
(case? curr-input)
|
||||
(spell? curr-input))
|
||||
(fail-res (cdr input)
|
||||
(let-values ([(chance kind may-use)
|
||||
(cond
|
||||
|
|
@ -139,7 +130,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])
|
||||
#;(!!! (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)
|
||||
|
|
@ -155,7 +146,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)
|
||||
#;(when (res? pre-build-ans) (printf "pre-build is a res~n"))
|
||||
#;(when (pair? pre-build-ans) (printf "pre-build is a pair of length ~a~n"
|
||||
(length pre-build-ans)))
|
||||
|
|
@ -227,7 +218,8 @@
|
|||
#;(printf "seq-walker called: last case, ~a case of ~a ~n"
|
||||
seq-name (curr-pred return-name))
|
||||
(build-error (curr-pred input last-src)
|
||||
(previous? input) (previous? return-name) #f
|
||||
(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"
|
||||
|
|
@ -235,26 +227,27 @@
|
|||
(let ([fst (curr-pred input last-src)])
|
||||
(cond
|
||||
[(res? fst)
|
||||
#;(!!! (printf "res case ~a ~a~n" seq-name (length seen)))
|
||||
#;(printf "res case ~a ~a~n" seq-name (length seen))
|
||||
(cond
|
||||
[(res-a fst) (next-call fst fst fst (res-msg fst)
|
||||
(and id-spot? (res-id fst))
|
||||
(res-first-tok fst) alts)]
|
||||
[else
|
||||
#;(printf "error situation ~a ~a~n" seq-name (length seen))
|
||||
(build-error fst (previous? input) (previous? return-name)
|
||||
(build-error fst (lambda () (previous? input))
|
||||
(previous? return-name)
|
||||
(car next-preds) look-back look-back-ref used curr-id
|
||||
seen alts last-src)])]
|
||||
[(repeat-res? fst)
|
||||
#;(!!! (printf "repeat-res: ~a ~a~n" seq-name (length seen)))
|
||||
#;(!!! (printf "res? ~a~n" (res? (repeat-res-a fst))))
|
||||
#;(printf "repeat-res: ~a ~a~n" seq-name (length seen))
|
||||
#;(printf "res? ~a~n" (res? (repeat-res-a fst)))
|
||||
(next-call (repeat-res-a fst) fst fst
|
||||
(res-msg (repeat-res-a fst)) #f
|
||||
(res-first-tok (repeat-res-a fst)) alts)]
|
||||
[(or (choice-res? fst) (pair? fst))
|
||||
#;(!!! (printf "choice-res or pair: ~a ~a ~a~n"
|
||||
(choice-res? fst)
|
||||
seq-name (length seen)))
|
||||
#;(printf "choice-res or pair: ~a ~a ~a~n"
|
||||
(choice-res? fst)
|
||||
seq-name (length seen))
|
||||
(let*-values
|
||||
([(lst name curr)
|
||||
(if (choice-res? fst)
|
||||
|
|
@ -267,18 +260,18 @@
|
|||
(map (lambda (res)
|
||||
(cond
|
||||
[(res? res)
|
||||
#;(!!! (printf "choice-res, res ~a ~a~n" seq-name (length seen)))
|
||||
#;(printf "choice-res, res ~a ~a~n" seq-name (length seen))
|
||||
(next-call res (curr res) res (name res)
|
||||
(and id-spot? (res-id res))
|
||||
(res-first-tok res) new-alts)]
|
||||
[(repeat-res? res)
|
||||
#;(!!! (printf "choice-res, repeat-res ~a ~a ~a~n"
|
||||
(res? (repeat-res-a res)) seq-name (length seen)))
|
||||
#;(printf "choice-res, repeat-res ~a ~a ~a~n"
|
||||
(res? (repeat-res-a res)) seq-name (length seen))
|
||||
(next-call (repeat-res-a res) res (repeat-res-a res)
|
||||
(res-msg (repeat-res-a res)) #f
|
||||
(res-first-tok (repeat-res-a res))
|
||||
new-alts)]
|
||||
[else (!!! (error 'parser-internal-error4 (format "~a" res)))]))
|
||||
[else (error 'parser-internal-error4 (format "~a" res))]))
|
||||
(flatten lst))]
|
||||
[(correct-rsts) (flatten (correct-list rsts))])
|
||||
#;(printf "case ~a ~a, choice case: intermediate results are ~a~n"
|
||||
|
|
@ -347,12 +340,9 @@
|
|||
(let ([inn (repeat-res-a rpt)]
|
||||
[stop (repeat-res-stop rpt)])
|
||||
#;(printf "in repeat->res for ~a~n" name)
|
||||
#;(printf "repeat-res-a res ~a~n" (res? inn))
|
||||
#;(printf "fail-type? stop ~a~n" (fail-type? stop))
|
||||
#;(when (fail-type? stop)
|
||||
(printf "stoped on ~a~n" (fail-type-name stop)))
|
||||
#;(printf "stop ~a~n" stop)
|
||||
#;(printf "choice-res? back ~a~n" (choice-res? back))
|
||||
#;(when (choice-res? back)
|
||||
(printf "back on ~a~n" (choice-res-name back)))
|
||||
#;(when (choice-res? back) (printf "choice-res-errors back ~a~n"
|
||||
|
|
@ -388,10 +378,10 @@
|
|||
[(or (and (res? old-res) (res-a old-res)) (choice-res? old-res))
|
||||
old-res]
|
||||
[(repeat-res? old-res)
|
||||
#;(!!! (printf "finished on repeat-res for ~a res ~n" name #;old-res))
|
||||
#;(printf "finished on repeat-res for ~a res ~n" name #;old-res)
|
||||
(repeat->res old-res look-back)]
|
||||
[(pair? old-res)
|
||||
#;(!!! (printf "finished on pairs of res for ~a~n" name #;old-res))
|
||||
#;(printf "finished on pairs of res for ~a~n" name #;old-res)
|
||||
(map (lambda (r) (repeat->res r look-back)) (flatten old-res))]
|
||||
[else
|
||||
#;(printf "There actually was an error for ~a~n" name)
|
||||
|
|
@ -525,7 +515,7 @@
|
|||
|
||||
;greedy-repeat: (list 'a) -> result -> (list 'a) -> result
|
||||
(define (repeat-greedy sub)
|
||||
(letrec ([repeat-name (string-append "any number of " (sub return-name))]
|
||||
(letrec ([repeat-name (lambda () (string-append "any number of " (sub return-name)))]
|
||||
[memo-table (make-weak-map)]
|
||||
[process-rest
|
||||
(lambda (curr-ans rest-ans)
|
||||
|
|
@ -542,7 +532,7 @@
|
|||
[(res? r)
|
||||
#;(printf "rest is a res for ~a, res-a is ~a ~n" a repeat-name)
|
||||
(make-repeat-res
|
||||
(make-res (append a (res-a r)) (res-rest r) repeat-name #f
|
||||
(make-res (append a (res-a r)) (res-rest r) (repeat-name) #f
|
||||
(+ (res-used curr-ans) (res-used r))
|
||||
#f (res-first-tok r))
|
||||
(repeat-res-stop rest-ans))]
|
||||
|
|
@ -569,7 +559,7 @@
|
|||
[else prev-src]))])
|
||||
(opt-lambda (input [start-src (list 1 0 1 0)] [alts 1])
|
||||
(cond
|
||||
[(eq? input return-name) repeat-name]
|
||||
[(eq? input return-name) (repeat-name)]
|
||||
[(weak-map-get memo-table input #f)(weak-map-get memo-table input)]
|
||||
[else
|
||||
(let ([ans
|
||||
|
|
@ -579,12 +569,12 @@
|
|||
(cond
|
||||
[(null? curr-input)
|
||||
#;(printf "out of input for ~a~n" repeat-name)
|
||||
(make-repeat-res (make-res null null repeat-name "" 0 #f #f) 'out-of-input)]
|
||||
(make-repeat-res (make-res null null (repeat-name) "" 0 #f #f) 'out-of-input)]
|
||||
#;[(weak-map-get memo-table curr-input #f)
|
||||
(weak-map-get memo-table curr-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)
|
||||
|
|
@ -600,7 +590,7 @@
|
|||
[(options-fail? (res-msg this-res)) 'options]
|
||||
[else 'terminal])
|
||||
(fail-type-chance (res-msg this-res)))
|
||||
(let ([fail (make-repeat-res (make-res null curr-input repeat-name "" 0 #f #f)
|
||||
(let ([fail (make-repeat-res (make-res null curr-input (repeat-name) "" 0 #f #f)
|
||||
(res-msg this-res))])
|
||||
#;(weak-map-put! memo-table curr-input fail)
|
||||
fail)]
|
||||
|
|
@ -631,29 +621,34 @@
|
|||
list-of-answer)]))]
|
||||
[else (error 'internal-parser-error8 (format "~a" this-res))]))]))])
|
||||
(weak-map-put! memo-table input ans)
|
||||
#;(!!! (printf "repeat of ~a ended with ans ~n" repeat-name #;ans))
|
||||
#;(printf "repeat of ~a ended with ans ~n" repeat-name #;ans)
|
||||
ans)]))))
|
||||
|
||||
;choice: [list [[list 'a ] -> result]] name -> result
|
||||
(define (choice opt-list name)
|
||||
(let ([memo-table (make-weak-map)]
|
||||
[num-choices (length opt-list)]
|
||||
[choice-names (map (lambda (o) (o return-name)) 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])
|
||||
#;(!!! (printf "choice ~a~n" name))
|
||||
#;(!!! (printf "possible options are ~a~n" choice-names))
|
||||
#;(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
|
||||
[(weak-map-get memo-table input #f) (weak-map-get memo-table input)]
|
||||
[(eq? input return-name) name]
|
||||
[else
|
||||
#;(!!! (printf "choice ~a~n" name))
|
||||
#;(!!! (printf "possible options are ~a~n" choice-names))
|
||||
#;(printf "choice ~a~n" name)
|
||||
#;(printf "possible options are ~a~n" choice-names)
|
||||
(let*-values
|
||||
([(options) (map (lambda (term) (term input last-src sub-opts)) opt-list)]
|
||||
#;[a (!!! (printf "choice-options ~a ~n ~a ~n~n~n" choice-names options))]
|
||||
[(fails) (map (lambda (x) (if (res? x) (res-msg x) (error 'here-non-res)))
|
||||
options)]
|
||||
#;[a (printf "choice-options ~a ~n ~a ~n~n~n" choice-names options)]
|
||||
[(fails) (map (lambda (x)
|
||||
(cond
|
||||
[(res? x) (res-msg x)]
|
||||
[(repeat-res? x) (res-msg (repeat-res-a x))]
|
||||
[(choice-res? x) (choice-res-errors x)]
|
||||
[else (error 'here-non-res x)]))
|
||||
(flatten options))]
|
||||
[(corrects errors) (split-list options)]
|
||||
[(fail-builder)
|
||||
(lambda (fails)
|
||||
|
|
@ -669,14 +664,14 @@
|
|||
name
|
||||
(rank-choice (map fail-type-used fails))
|
||||
(rank-choice (map fail-type-may-use fails))
|
||||
num-choices choice-names
|
||||
num-choices (choice-names)
|
||||
(null? input)
|
||||
fails)))]
|
||||
[(ans)
|
||||
(cond
|
||||
[(null? corrects) (fail-res input (fail-builder fails))]
|
||||
[else (make-choice-res name corrects (fail-builder errors))])])
|
||||
#;(!!! (printf "choice ~a is returning options were ~a ~n" name choice-names))
|
||||
#;(printf "choice ~a is returning options were ~a ~n" name (choice-names))
|
||||
#;(printf "corrects were ~a~n" corrects)
|
||||
#;(printf "errors were ~a~n" errors)
|
||||
(weak-map-put! memo-table input ans) ans)])))))
|
||||
|
|
@ -744,8 +739,8 @@
|
|||
(list (position-line new-start)
|
||||
(position-col new-start)
|
||||
(position-offset new-start)
|
||||
(+ (- (!!! (third src))
|
||||
(!!! (position-offset new-start)))
|
||||
(+ (- (third src)
|
||||
(position-offset new-start))
|
||||
(fourth src))))
|
||||
|
||||
(define (update-src-end src new-end)
|
||||
|
|
@ -756,13 +751,14 @@
|
|||
(- (position-offset new-end) (third src))))
|
||||
|
||||
(define (repeat op)
|
||||
(letrec ([name (string-append "any number of "(op return-name))]
|
||||
(letrec ([name (lambda () "temp") #;(lambda () (string-append "any number of " (op return-name)))]
|
||||
[r* (choice (list op
|
||||
(seq (list op r*)
|
||||
(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)
|
||||
(name))
|
||||
(seq null (lambda (x) null) return-name))
|
||||
name)])
|
||||
(name))])
|
||||
r*))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,13 +1,10 @@
|
|||
(module errors mzscheme
|
||||
(module errors scheme/base
|
||||
|
||||
(require "structs.scm" "parser-sigs.ss")
|
||||
|
||||
(require lazy/force
|
||||
mzlib/etc
|
||||
mzlib/unit
|
||||
mzlib/list)
|
||||
|
||||
(provide (all-defined))
|
||||
(require scheme/unit)
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define-unit error-formatting@
|
||||
(import error-format-parameters^ language-format-parameters^ out^)
|
||||
|
|
@ -19,9 +16,7 @@
|
|||
|
||||
;fail-type->message: fail-type (listof err) -> err
|
||||
(define (fail-type->message fail-type message-to-date)
|
||||
(let* ([fail-type (!!!-fail fail-type)]
|
||||
[input->output-name (!!! input->output-name)]
|
||||
[name (fail-type-name fail-type)]
|
||||
(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)
|
||||
|
|
@ -219,7 +214,7 @@
|
|||
|
||||
(define (select-errors opts-list)
|
||||
(let* ([composite-winners
|
||||
(narrow-opts composite (!!list opts-list))]
|
||||
(narrow-opts composite opts-list)]
|
||||
|
||||
[chance-used-winners
|
||||
(narrow-opts chance-used composite-winners)]
|
||||
|
|
|
|||
|
|
@ -1,12 +1,10 @@
|
|||
(module parser-sigs mzscheme
|
||||
(module parser-sigs scheme
|
||||
|
||||
(require mzlib/unit)
|
||||
|
||||
(require (only mzlib/etc opt-lambda)) ; Required for expansion
|
||||
(require parser-tools/lex
|
||||
mzlib/string mzlib/list)
|
||||
(require (only-in (lib "etc.ss") opt-lambda)) ; Required for expansion
|
||||
(require (lib "lex.ss" "parser-tools")
|
||||
(lib "string.ss"))
|
||||
|
||||
(provide (all-defined))
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define-signature-form (terminals stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -15,9 +13,9 @@
|
|||
(andmap identifier? (syntax->list #'(elt ...))))
|
||||
(syntax->list #`(elt ...
|
||||
#,@(map (lambda (e)
|
||||
(datum->syntax-object e
|
||||
(string->symbol
|
||||
(format "token-~a" (syntax-e e)))))
|
||||
(datum->syntax e
|
||||
(string->symbol
|
||||
(format "token-~a" (syntax-e e)))))
|
||||
(syntax->list #'(elt ...)))))]))
|
||||
|
||||
(define-signature language-dictionary^ (misspelled misscap missclass))
|
||||
|
|
|
|||
|
|
@ -1,32 +1,31 @@
|
|||
(module structs mzscheme
|
||||
(module structs scheme/base
|
||||
|
||||
(provide (all-defined-except make-fail-type))
|
||||
(provide (all-defined-out) #;(except-out make-fail-type))
|
||||
|
||||
(require lazy/force
|
||||
parser-tools/lex)
|
||||
(require parser-tools/lex)
|
||||
|
||||
;fail-src: (list line col pos span loc)
|
||||
|
||||
;make-src-lst: position position -> src-list
|
||||
(define (make-src-lst start end)
|
||||
(list (!!! (position-line start))
|
||||
(!!! (position-col start))
|
||||
(!!! (position-offset start))
|
||||
(- (!!! (position-offset end))
|
||||
(!!! (position-offset start)))))
|
||||
(list (position-line start)
|
||||
(position-col start)
|
||||
(position-offset start)
|
||||
(- (position-offset end)
|
||||
(position-offset start))))
|
||||
|
||||
;(make-fail-type float fail-src string int int)
|
||||
(define-struct fail-type (chance src name used may-use) (make-inspector))
|
||||
(define-struct fail-type (chance src name used may-use) #:transparent)
|
||||
;(make-terminal-fail float fail-src string symbol 'a)
|
||||
(define-struct (terminal-fail fail-type) (kind found))
|
||||
;(make-sequence-fail float fail-src string symbol (list string) string 'a boolean string)
|
||||
(define-struct (sequence-fail fail-type) (id kind correct expected found repeat? last-seen))
|
||||
;(make-choice-fail float fail-src string int (list string) (list fail-type) boolean)
|
||||
(define-struct (choice-fail fail-type) (options names ended? messages) (make-inspector))
|
||||
(define-struct (choice-fail fail-type) (options names ended? messages) #:transparent)
|
||||
;(make-options-fail float #f #f (list fail-type))
|
||||
(define-struct (options-fail fail-type) (opts))
|
||||
|
||||
(define (!!!-fail fail)
|
||||
#;(define (!!!-fail fail)
|
||||
(let*-values ([(chance src name used may-use)
|
||||
(if (fail-type? fail)
|
||||
(values (!!! (fail-type-chance fail))
|
||||
|
|
@ -66,11 +65,11 @@
|
|||
;result = res | choice-res | repeat-res | (listof (U res choice-res))
|
||||
|
||||
;(make-res (U #f (listof 'b)) (listof 'a) (U string fail-type) (U string 'a) int) [U #f fail-type] token
|
||||
(define-struct res (a rest msg id used possible-error first-tok) (make-inspector))
|
||||
(define-struct res (a rest msg id used possible-error first-tok) #:transparent)
|
||||
;make-choice-res string (listof res fail-type)
|
||||
(define-struct choice-res (name matches errors) (make-inspector))
|
||||
(define-struct choice-res (name matches errors) #:transparent)
|
||||
;(make-repeat-res answer (U symbol fail-type))
|
||||
(define-struct repeat-res (a stop) (make-inspector))
|
||||
(define-struct repeat-res (a stop) #:transparent)
|
||||
|
||||
(define (fail-res rst msg) (make-res #f rst msg "" 0 #f #f))
|
||||
|
||||
|
|
|
|||
|
|
@ -84,9 +84,9 @@
|
|||
|
||||
;Statement signatures
|
||||
|
||||
(define-signature statements^ (make-statement if-s return-s this-call super-ctor-call
|
||||
block expression-stmt while-l do-while for-l
|
||||
break-s cont-s init))
|
||||
(define-signature statements^ (if-s return-s this-call super-ctor-call
|
||||
block expression-stmt while-l do-while for-l
|
||||
break-s cont-s init))
|
||||
|
||||
;Member signatures
|
||||
|
||||
|
|
@ -105,286 +105,3 @@
|
|||
(define-signature top-forms^ (top-member import-dec make-program))
|
||||
|
||||
)
|
||||
;
|
||||
; ;
|
||||
; ;
|
||||
; ; ;;;;
|
||||
; ; ;
|
||||
; ; ;
|
||||
; ; ; ;;;;; ;; ;;; ;;;; ;; ;; ;;; ;;;;; ;;;; ;; ;;;;; ;;;; ;
|
||||
; ; ; ; ;; ; ; ;; ; ; ; ; ;; ; ; ; ;;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ;;;;;; ; ; ; ; ; ; ;;;;;; ; ; ;;;;;;;;; ;;;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ;; ; ; ; ;; ; ;; ; ;; ; ;; ; ;; ;; ;
|
||||
; ; ;;;;;;; ;;;; ;; ;;; ;;; ;;;; ; ;;; ;; ;;;; ;; ;;;; ; ;;;;; ; ;;;;
|
||||
; ; ; ;
|
||||
; ; ; ;
|
||||
; ; ;;;;; ;;;;;
|
||||
;
|
||||
; (define beginner-unique-base
|
||||
; (simple-expression
|
||||
; (list (literals (list boolean-lits textual-lits prim-numeric-lits double-lits))
|
||||
; this
|
||||
; IDENTIFIER
|
||||
; (new-class IDENTIFIER (eta beginner-expression))
|
||||
; (simple-method-call (eta beginner-expression))
|
||||
; (sequence (O_PAREN (eta beginner-expression) C_PAREN) id "expression")
|
||||
; (sequence (! (eta beginner-expression)) id "unary expression")
|
||||
; (checks (eta beginner-expression)))))
|
||||
;
|
||||
; (define beginner-unique-end
|
||||
; (simple-expression
|
||||
; (list field-access-end
|
||||
; (method-call-end (eta beginner-expression))
|
||||
; (binary-expression-end (bin-ops (list math-ops compare-ops bool-ops))
|
||||
; (eta beginner-expression)))))
|
||||
;
|
||||
; (define beginner-expression
|
||||
; (sequence (beginner-unique-base (repeat beginner-unique-end)) id "expression"))
|
||||
;
|
||||
; (define beginner-statement
|
||||
; (statement (list (if-s beginner-expression (eta beginner-statement) #f)
|
||||
; (return-s beginner-expression #f))))
|
||||
;
|
||||
; (define beginner-field (field #f value-type beginner-expression #f))
|
||||
;
|
||||
; (define beginner-method-sig
|
||||
; (method-signature #f value-type args))
|
||||
;
|
||||
; (define beginner-method
|
||||
; (method beginner-method-sig beginner-statement))
|
||||
;
|
||||
; (define beginner-constructor (constructor #f init*))
|
||||
;
|
||||
; (define beginner-interface
|
||||
; (interface-def #f #f (method-header* beginner-method-sig)))
|
||||
;
|
||||
; (define beginner-class
|
||||
; (class-def #f #f (implements-dec IDENTIFIER)
|
||||
; (repeat (class-body (list beginner-field beginner-method beginner-constructor)))))
|
||||
;
|
||||
; (define beginner-program
|
||||
; (program #f (repeat import-dec)
|
||||
; (repeat (top-member (list beginner-class beginner-interface)))))
|
||||
;
|
||||
; (define parse-beginner (parser beginner-program))
|
||||
;
|
||||
; (define intermediate-unique-base
|
||||
; (simple-expression
|
||||
; (list (literals (list boolean-lits textual-lits prim-numeric-lits double-lits))
|
||||
; this
|
||||
; IDENTIFIER
|
||||
; (new-class IDENTIFIER (eta intermediate-expression))
|
||||
; (simple-method-call (eta intermediate-expression))
|
||||
; (sequence (O_PAREN (eta intermediate-expression) C_PAREN) id "expression")
|
||||
; (sequence (! (eta intermediate-expression)) id "unary expression")
|
||||
; (cast value-type (eta intermediate-expression))
|
||||
; (super-call (eta intermediate-expression))
|
||||
; (checks (eta intermediate-expression)))))
|
||||
;
|
||||
; (define intermediate-unique-end
|
||||
; (simple-expression
|
||||
; (list field-access-end
|
||||
; (method-call-end (eta intermediate-expression))
|
||||
; (binary-expression-end (bin-ops (list math-ops compare-ops bool-ops bit-ops))
|
||||
; (eta intermediate-expression)))))
|
||||
;
|
||||
; (define intermediate-expression
|
||||
; (sequence (intermediate-unique-base (repeat intermediate-unique-end))
|
||||
; id "expression"))
|
||||
;
|
||||
; (define intermediate-stmt-expr
|
||||
; (simple-expression (list (new-class IDENTIFIER intermediate-expression)
|
||||
; (super-call intermediate-expression)
|
||||
; (sequence (intermediate-expression
|
||||
; (method-call-end intermediate-expression))
|
||||
; id "method call")
|
||||
; (assignment IDENTIFIER EQUAL intermediate-expression))))
|
||||
;
|
||||
; (define intermediate-statement
|
||||
; (statement (list (if-s intermediate-expression (eta intermediate-statement) #f)
|
||||
; (return-s intermediate-expression #t)
|
||||
; (variable-declaration value-type intermediate-expression #f "local variable")
|
||||
; (block (repeat (eta intermediate-statement)))
|
||||
; (sequence (intermediate-stmt-expr SEMI_COLON) id "statement"))))
|
||||
;
|
||||
; (define intermediate-field (field access-mods value-type intermediate-expression #t))
|
||||
;
|
||||
; (define intermediate-method-sig-no-abs
|
||||
; (method-signature access-mods
|
||||
; (method-type value-type)
|
||||
; args))
|
||||
; (define intermediate-method-sig-abs
|
||||
; (method-signature (method-mods access-mods)
|
||||
; (method-type value-type)
|
||||
; args))
|
||||
;
|
||||
; (define intermediate-method
|
||||
; (choose ((method intermediate-method-sig-no-abs intermediate-statement)
|
||||
; (method-header intermediate-method-sig-abs)) "method definition top"))
|
||||
;
|
||||
; (define intermediate-constructor
|
||||
; (constructor access-mods
|
||||
; (choose ((sequence ((super-call intermediate-expression) (repeat intermediate-statement)) id)
|
||||
; (sequence ((this-call intermediate-expression) (repeat intermediate-statement)) id)
|
||||
; (repeat intermediate-statement)) "constructor body")))
|
||||
;
|
||||
; (define intermediate-interface
|
||||
; (interface-def
|
||||
; #f
|
||||
; (sequence (extends (comma-sep IDENTIFIER "interfaces")) id "extends")
|
||||
; (method-header* intermediate-method-sig-no-abs)))
|
||||
;
|
||||
; (define intermediate-class
|
||||
; (class-def abstract (extend-dec IDENTIFIER) (implements-dec (comma-sep IDENTIFIER "interfaces"))
|
||||
; (repeat (class-body (list intermediate-field intermediate-method intermediate-constructor)))))
|
||||
;
|
||||
; (define intermediate-program
|
||||
; (program #f (repeat import-dec)
|
||||
; (repeat (top-member (list intermediate-class intermediate-interface)))))
|
||||
;
|
||||
; (define parse-intermediate (parser intermediate-program))
|
||||
;
|
||||
; (define advanced-unique-base
|
||||
; (simple-expression
|
||||
; (list (literals (list boolean-lits textual-lits prim-numeric-lits double-lits))
|
||||
; this
|
||||
; IDENTIFIER
|
||||
; (new-class IDENTIFIER (eta advanced-expression))
|
||||
; (simple-method-call (eta advanced-expression))
|
||||
; (new-array value-type (eta advanced-expression))
|
||||
; (sequence (O_PAREN (eta advanced-expression) C_PAREN) id "expression")
|
||||
; (sequence (! (eta advanced-expression)) id "unary expression")
|
||||
; (cast value-type (eta advanced-expression))
|
||||
; (super-call (eta advanced-expression))
|
||||
; (checks (eta advanced-expression)))))
|
||||
;
|
||||
; (define advanced-unique-end
|
||||
; (simple-expression
|
||||
; (list field-access-end
|
||||
; (array-access-end (eta advanced-expression))
|
||||
; (method-call-end (eta advanced-expression))
|
||||
; (if-expr-end (eta advanced-expression))
|
||||
; (binary-expression-end (bin-ops (list math-ops compare-ops bool-ops))
|
||||
; (eta advanced-expression)))))
|
||||
;
|
||||
; (define advanced-expression
|
||||
; (sequence (advanced-unique-base (repeat advanced-unique-end)) id "expression"))
|
||||
;
|
||||
;
|
||||
; (define advanced-stmt-expr
|
||||
; (simple-expression (list (new-class IDENTIFIER advanced-expression)
|
||||
; (super-call advanced-expression)
|
||||
; (sequence (advanced-expression
|
||||
; (method-call-end advanced-expression)) id "method call")
|
||||
; (assignment IDENTIFIER assignment-ops advanced-expression)
|
||||
; (sequence (advanced-expression ++) id "unary mutation")
|
||||
; (sequence (advanced-expression --) id "unary mutation")
|
||||
; (sequence (++ advanced-expression) id "unary mutation")
|
||||
; (sequence (-- advanced-expression) id "unary mutation"))))
|
||||
;
|
||||
; (define advanced-statement
|
||||
; (statement (list (if-s advanced-expression (eta advanced-statement) #t)
|
||||
; (return-s advanced-expression #t)
|
||||
; (variable-declaration value-type advanced-expression #t "local variable")
|
||||
; (block (repeat (eta advanced-statement)))
|
||||
; (sequence (advanced-stmt-expr SEMI_COLON) id "statement")
|
||||
; (for-l (choose ((variable-declaration value-type advanced-expression #t "for loop variable")
|
||||
; (comma-sep advanced-stmt-expr "initializations")) "for loop initialization")
|
||||
; #t
|
||||
; advanced-expression #t
|
||||
; (comma-sep advanced-stmt-expr "for loop increments") #t (eta advanced-statement))
|
||||
; (while-l advanced-expression (eta advanced-statement))
|
||||
; (do-while advanced-expression (eta advanced-statement))
|
||||
; (break-s #f)
|
||||
; (cont-s #f))))
|
||||
;
|
||||
; (define advanced-field (field (global-mods access-mods) value-type advanced-expression #t))
|
||||
;
|
||||
; (define advanced-method-sig-no-abs
|
||||
; (method-signature (global-mods access-mods)
|
||||
; (method-type value-type)
|
||||
; args))
|
||||
; (define advanced-method-sig-abs
|
||||
; (method-signature (method-mods (global-mods access-mods))
|
||||
; (method-type value-type)
|
||||
; args))
|
||||
;
|
||||
; (define advanced-method
|
||||
; (choose ((method advanced-method-sig-no-abs advanced-statement)
|
||||
; (method-header advanced-method-sig-abs)) "method definition"))
|
||||
;
|
||||
; (define advanced-constructor
|
||||
; (constructor access-mods
|
||||
; (choose ((sequence ((super-call advanced-expression) (repeat advanced-statement)) id)
|
||||
; (sequence ((this-call advanced-expression) (repeat advanced-statement)) id)
|
||||
; (repeat advanced-statement)) "constructor body")))
|
||||
;
|
||||
; (define advanced-interface
|
||||
; (interface-def
|
||||
; #f
|
||||
; (sequence (extends (comma-sep IDENTIFIER "interfaces")) id "extends")
|
||||
; (method-header* advanced-method-sig-no-abs)))
|
||||
;
|
||||
; (define advanced-class
|
||||
; (class-def abstract (extend-dec IDENTIFIER) (implements-dec (comma-sep IDENTIFIER "interfaces"))
|
||||
; (repeat (class-body (list advanced-field advanced-method advanced-constructor
|
||||
; (method-header advanced-method-sig-abs))))))
|
||||
;
|
||||
; (define advanced-program
|
||||
; (program (sequence (package name SEMI_COLON) id "package specification")
|
||||
; (repeat import-dec)
|
||||
; (repeat (top-member (list advanced-class advanced-interface)))))
|
||||
;
|
||||
; (define parse-advanced
|
||||
; (parser advanced-program))
|
||||
;
|
||||
; (define (old-tokens->new tok-list)
|
||||
; (cond
|
||||
; [(null? tok-list) null]
|
||||
; [else
|
||||
; (cons
|
||||
; (make-position-token
|
||||
; (case (token-name (position-token-token (car tok-list)))
|
||||
; [(=) (token-EQUAL)]
|
||||
; ((<) (token-LT))
|
||||
; ((>) (token-GT))
|
||||
; ((<=) (token-LTEQ))
|
||||
; ((>=) (token-GTEQ))
|
||||
; ((+) (token-PLUS))
|
||||
; ((-) (token-MINUS))
|
||||
; ((*) (token-TIMES))
|
||||
; ((/) (token-DIVIDE))
|
||||
; ((^) (token-^T))
|
||||
; ((if) (token-ifT))
|
||||
; ((do) (token-doT))
|
||||
; ((case) (token-caseT))
|
||||
; ((else) (token-elseT))
|
||||
; ((void) (token-voidT))
|
||||
; (else (position-token-token (car tok-list))))
|
||||
; (position-token-start-pos (car tok-list))
|
||||
; (position-token-end-pos (car tok-list)))
|
||||
; (old-tokens->new (cdr tok-list)))]))
|
||||
;
|
||||
; )
|
||||
;
|
||||
; (define-unit constants@
|
||||
; (import)
|
||||
; (export error-format-parameters^)
|
||||
; (define src? #t)
|
||||
; (define input-type "file")
|
||||
; (define show-options #f)
|
||||
; (define max-depth 1)
|
||||
; (define max-choice-depth 3))
|
||||
;
|
||||
; (define-compound-unit/infer java-parsers@
|
||||
; (import)
|
||||
; (export teaching-languages^)
|
||||
; (link java-dictionary@ combinator-parser-tools@ constants@ java-grammars@))
|
||||
;
|
||||
; (provide java-parsers@ teaching-languages^)
|
||||
;
|
||||
; )
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,12 +1,10 @@
|
|||
(module parser-units lazy
|
||||
|
||||
(require mzlib/unit)
|
||||
|
||||
(module parser-units scheme/base
|
||||
|
||||
(require parser-tools/lex
|
||||
scheme/unit
|
||||
(lib "combinator-unit.ss" "combinator-parser")
|
||||
"java-signatures.scm"
|
||||
mzlib/string)
|
||||
|
||||
|
||||
(define-signature language-forms^ (program statement expression field interact)) ;value-type method-type))
|
||||
|
||||
|
|
@ -21,10 +19,10 @@
|
|||
(define class-type "keyword")
|
||||
|
||||
(define (output-map x)
|
||||
#;(!!! (printf "in output-map ~a~n" x))
|
||||
(! (when (position-token? x)
|
||||
(set! x (position-token-token x))))
|
||||
(! (case (token-name x)
|
||||
#;(printf "in output-map ~a~n" x)
|
||||
(when (position-token? x)
|
||||
(set! x (position-token-token x)))
|
||||
(case (token-name x)
|
||||
[(PIPE) "|"]
|
||||
[(OR) "||"]
|
||||
[(OREQUAL) "|="]
|
||||
|
|
@ -62,7 +60,7 @@
|
|||
HEX_LIT OCT_LIT HEXL_LIT OCTL_LIT) (token-value x)]
|
||||
[(IDENTIFIER) (format "identifier ~a" (token-value x))]
|
||||
[(STRING_ERROR) (format "misformatted string ~a" (token-value x))]
|
||||
[else (token-name x)])))
|
||||
[else (token-name x)]))
|
||||
|
||||
(define (java-keyword? t)
|
||||
(memq t `(? this super new instanceof while try throw synchronized switch return ifT goto for finally
|
||||
|
|
@ -264,10 +262,11 @@
|
|||
(export general-productions^)
|
||||
|
||||
(define (comma-sep term name)
|
||||
(sequence (term (repeat (sequence (COMMA term) id))) id (string-append "a list of " name)))
|
||||
(sequence (term (repeat (sequence (COMMA term) id (string-append "a list of " name))))
|
||||
id (string-append "a list of " name)))
|
||||
|
||||
(define name
|
||||
(sequence (IDENTIFIER (repeat (sequence (PERIOD IDENTIFIER) id))) id "name"))
|
||||
(sequence (IDENTIFIER (repeat (sequence (PERIOD IDENTIFIER) id "name"))) id "name"))
|
||||
|
||||
)
|
||||
|
||||
|
|
@ -304,9 +303,6 @@
|
|||
java-operators^ java-extras^ language-forms^)
|
||||
(export expr-lits^ expr-terms+^ expr-tails^)
|
||||
|
||||
(define (simple-expression exprs)
|
||||
(choice exprs "expression"))
|
||||
|
||||
(define boolean-lits
|
||||
(choose (TRUE_LIT FALSE_LIT) "boolean literal"))
|
||||
|
||||
|
|
@ -333,7 +329,7 @@
|
|||
|
||||
(define new-class
|
||||
(choose ((sequence (new name O_PAREN C_PAREN) id)
|
||||
(sequence (new name O_PAREN (comma-sep expression "arguments") C_PAREN) id))
|
||||
(sequence (new name O_PAREN (comma-sep (eta expression) "arguments") C_PAREN) id))
|
||||
"class instantiation"))
|
||||
|
||||
(define (new-array type-name)
|
||||
|
|
@ -351,8 +347,9 @@
|
|||
|
||||
(define array-init
|
||||
(letrec ([base-init (array-init-maker (eta expression))]
|
||||
[simple-init (array-init-maker (choose (expression base-init (eta init)) "array initializations"))]
|
||||
[init (array-init-maker (choose (expression simple-init) "array initialization"))])
|
||||
[simple-init (array-init-maker
|
||||
(choose ((eta expression) base-init (eta init)) "array initializations"))]
|
||||
[init (array-init-maker (choose ((eta expression) simple-init) "array initialization"))])
|
||||
init #;(sequence (new type-name init) "array initialization")))
|
||||
|
||||
(define (binary-expression-end op)
|
||||
|
|
@ -364,40 +361,40 @@
|
|||
(define simple-method-call
|
||||
(choose
|
||||
((sequence ((^ identifier) O_PAREN C_PAREN) id)
|
||||
(sequence ((^ identifier) O_PAREN (comma-sep expression "arguments") C_PAREN) id))
|
||||
(sequence ((^ identifier) O_PAREN (comma-sep (eta expression) "arguments sm") C_PAREN) id))
|
||||
"method invocation"))
|
||||
|
||||
(define method-call-end
|
||||
(choose
|
||||
((sequence (PERIOD (^ identifier) O_PAREN C_PAREN) id)
|
||||
(sequence (PERIOD (^ identifier) O_PAREN (comma-sep expression "arguments") C_PAREN) id))
|
||||
(sequence (PERIOD (^ identifier) O_PAREN (comma-sep (eta expression) "arguments me") C_PAREN) id))
|
||||
"method invocation"))
|
||||
|
||||
(define (assignment asignee op)
|
||||
(sequence ((^ asignee) op expression) id "assignment"))
|
||||
(sequence ((^ asignee) op (eta expression)) id "assignment"))
|
||||
|
||||
(define unary-assignment-front
|
||||
(choose ((sequence (++ expression) id)
|
||||
(sequence (-- expression) id)) "unary modification"))
|
||||
(choose ((sequence (++ (eta expression)) id)
|
||||
(sequence (-- (eta expression)) id)) "unary modification"))
|
||||
|
||||
(define (unary-assignment-back base)
|
||||
(choose ((sequence (base ++) id)
|
||||
(sequence (base --) id)) "unary modification"))
|
||||
|
||||
(define (cast type)
|
||||
(sequence (O_PAREN type C_PAREN expression) id "cast expression"))
|
||||
(sequence (O_PAREN type C_PAREN (eta expression)) id "cast expression"))
|
||||
|
||||
(define instanceof-back
|
||||
(sequence (instanceof name) id "instanceof expression"))
|
||||
|
||||
(define super-ctor
|
||||
(choose ((sequence (super O_PAREN C_PAREN) id)
|
||||
(sequence (super O_PAREN (comma-sep expression "arguments") C_PAREN) id))
|
||||
(sequence (super O_PAREN (comma-sep (eta expression) "arguments") C_PAREN) id))
|
||||
"super constructor call"))
|
||||
|
||||
(define super-call
|
||||
(choose ((sequence (super PERIOD identifier O_PAREN C_PAREN) id)
|
||||
(sequence (super PERIOD identifier O_PAREN (comma-sep expression "arguments") C_PAREN) id))
|
||||
(sequence (super PERIOD identifier O_PAREN (comma-sep (eta expression) "arguments") C_PAREN) id))
|
||||
"super method invocation"))
|
||||
|
||||
(define checks
|
||||
|
|
@ -428,18 +425,18 @@
|
|||
|
||||
(define this-call
|
||||
(choose ((sequence (this O_PAREN C_PAREN SEMI_COLON) id)
|
||||
(sequence (this O_PAREN (comma-sep expression "arguments") C_PAREN SEMI_COLON) id)) "this constructor call"))
|
||||
(sequence (this O_PAREN (comma-sep (eta expression) "arguments") C_PAREN SEMI_COLON) id)) "this constructor call"))
|
||||
|
||||
(define super-ctor-call
|
||||
(choose ((sequence (super O_PAREN C_PAREN SEMI_COLON) id)
|
||||
(sequence (super O_PAREN (comma-sep expression "arguments") C_PAREN SEMI_COLON) id)) "super constructor call"))
|
||||
(sequence (super O_PAREN (comma-sep (eta expression) "arguments") C_PAREN SEMI_COLON) id)) "super constructor call"))
|
||||
|
||||
(define (block repeat?)
|
||||
(let ([body (if repeat? (repeat-greedy statement) statement)])
|
||||
(sequence (O_BRACE body C_BRACE) id "block statement")))
|
||||
|
||||
(define expression-stmt
|
||||
(sequence (expression SEMI_COLON) id "statement"))
|
||||
(sequence ((eta expression) SEMI_COLON) id "statement"))
|
||||
|
||||
(define (while-l stmt)
|
||||
(sequence (while O_PAREN expression C_PAREN stmt) id "while loop"))
|
||||
|
|
@ -484,9 +481,6 @@
|
|||
|
||||
(define init
|
||||
(sequence (this PERIOD IDENTIFIER EQUAL IDENTIFIER SEMI_COLON) id "field initialization"))
|
||||
|
||||
(define (make-statement statements)
|
||||
(choice statements "statement"))
|
||||
|
||||
)
|
||||
|
||||
|
|
@ -660,7 +654,7 @@
|
|||
(define statement
|
||||
(choose ((return-s #f) (if-s (block #f) #f)) "statement"))
|
||||
|
||||
(define field (make-field #f (value+name-type prim-type) expression #f))
|
||||
(define field (make-field #f (value+name-type prim-type) (eta expression) #f))
|
||||
|
||||
(define method-sig
|
||||
(method-signature #f (value+name-type prim-type) (args (value+name-type prim-type)) #f identifier))
|
||||
|
|
@ -743,7 +737,7 @@
|
|||
|
||||
(define statement (statement-c #f))
|
||||
|
||||
(define field (make-field #f (value+name-type prim-type) expression #t))
|
||||
(define field (make-field #f (value+name-type prim-type) (eta expression) #t))
|
||||
|
||||
(define method-sig-no-abs
|
||||
(method-signature #f (method-type (value+name-type prim-type))
|
||||
|
|
@ -850,7 +844,7 @@
|
|||
|
||||
(define statement (statement-c #f))
|
||||
|
||||
(define field (make-field access-mods (value+name-type prim-type) expression #t))
|
||||
(define field (make-field access-mods (value+name-type prim-type) (eta expression) #t))
|
||||
|
||||
(define method-sig-no-abs
|
||||
(method-signature access-mods (method-type (value+name-type prim-type))
|
||||
|
|
@ -980,7 +974,7 @@
|
|||
|
||||
(define field (make-field (global-mods access-mods)
|
||||
(array-type (value+name-type prim-type))
|
||||
(choose (expression array-init) "field initializer") #t))
|
||||
(eta (choose (expression array-init) "field initializer")) #t))
|
||||
|
||||
(define method-sig-no-abs
|
||||
(method-signature (global-mods access-mods)
|
||||
|
|
@ -1008,7 +1002,8 @@
|
|||
(sequence (tok:extends (comma-sep IDENTIFIER "interfaces")) id "extends")
|
||||
(repeat-greedy (choose ((sequence (method-sig-no-abs SEMI_COLON) id "method header")
|
||||
(make-field (global-mods access-mods)
|
||||
(array-type (value+name-type prim-type)) expression #t))
|
||||
(array-type (value+name-type prim-type))
|
||||
(eta expression) #t))
|
||||
"interface member definition"))))
|
||||
|
||||
(define class
|
||||
|
|
|
|||
|
|
@ -1,336 +1,13 @@
|
|||
(module parsers mzscheme
|
||||
(module parsers scheme/base
|
||||
(require "parser-units.scm"
|
||||
(only (lib "force.ss" "lazy") !!!)
|
||||
(only (lib "combinator-unit.ss" "combinator-parser") err^)
|
||||
mzlib/unit
|
||||
#;parser-tools/lex
|
||||
#;(prefix re: parser-tools/lex-sre))
|
||||
scheme/unit
|
||||
(only-in (lib "combinator-unit.ss" "combinator-parser") err^))
|
||||
|
||||
(provide parse-beginner parse-intermediate parse-intermediate+access parse-advanced
|
||||
parse-beginner-interact parse-intermediate-interact parse-advanced-interact)
|
||||
(define (trim-string s f l)
|
||||
(substring s f (- (string-length s) l)))
|
||||
|
||||
; (define-lex-abbrevs
|
||||
; ;; 3.4
|
||||
; (CR #\015)
|
||||
; (LF #\012)
|
||||
; (LineTerminator (re:or CR
|
||||
; LF
|
||||
; (re:: CR LF)))
|
||||
; (InputCharacter (re:~ CR LF))
|
||||
;
|
||||
; ;; 3.6
|
||||
; (FF #\014)
|
||||
; (TAB #\011)
|
||||
; (WhiteSpace (re:or #\space
|
||||
; TAB
|
||||
; FF
|
||||
; LineTerminator))
|
||||
;
|
||||
; ;; 3.7 (Had to transform CommentTail and CommentTailStar into one RE)
|
||||
; ;; (DocumentationComment only appears in version 1 of the spec)
|
||||
; (Comment (re:or TraditionalComment
|
||||
; EndOfLineComment
|
||||
; DocumentationComment))
|
||||
; (TraditionalComment (re:: "/*" NotStar CommentTail))
|
||||
; (EndOfLineComment (re:: "//" (re:* InputCharacter)))
|
||||
; (DocumentationComment (re:: "/**" CommentTailStar))
|
||||
; (CommentTail (re:: (re:* (re:: (re:* NotStar) (re:+ "*") NotStarNotSlash))
|
||||
; (re:* NotStar)
|
||||
; (re:+ "*")
|
||||
; "/"))
|
||||
; (CommentTailStar (re:: (re:* (re:: (re:* "*") NotStarNotSlash (re:* NotStar) "*"))
|
||||
; (re:* "*")
|
||||
; "/"))
|
||||
; (NotStar (re:~ "*"))
|
||||
; (NotStarNotSlash (re:~ "*" "/"))
|
||||
;
|
||||
; (SyntaxComment (re:or TraditionalCommentEOF
|
||||
; EndOfLineComment))
|
||||
; (TraditionalCommentEOF (re:: "/*" CommentTailEOF))
|
||||
; (CommentTailEOF (re:or (re:: (re:* (re:: (re:* NotStar) (re:+ "*") NotStarNotSlash))
|
||||
; (re:* NotStar)
|
||||
; (re:+ "*")
|
||||
; "/")
|
||||
; (re:: (re:* (re:: (re:* NotStar) (re:+ "*") NotStarNotSlash))
|
||||
; (re:* NotStar)
|
||||
; (re:* "*"))))
|
||||
;
|
||||
; ;; 3.8 (No need to worry about excluding keywords and such. They will
|
||||
; ;; appear first in the lexer spec)
|
||||
; ;Not UNICODE compliant
|
||||
; (Identifier (re:: JavaLetter (re:* JavaLetterOrDigit)))
|
||||
; (JavaLetter (re:or (re:/ "AZ" "az") "_" "$"))
|
||||
; (JavaLetterOrDigit (re:or JavaLetter (re:/ "09")))
|
||||
;
|
||||
; (KnownTypes (re:or "boolean" "byte" "char" "double" "float" "int" "long" "short"
|
||||
; "String" "Object"))
|
||||
;
|
||||
; ;; 3.9
|
||||
; (Keyword (re:or "abstract" "default" "if" "private" "this"
|
||||
; "boolean" "do" "implements" "protected" "throw"
|
||||
; "break" "double" "import" "public" "throws"
|
||||
; "byte" "else" "instanceof" "return" "transient"
|
||||
; "case" "extends" "int" "short" "try"
|
||||
; "catch" "final" "interface" "static" "void"
|
||||
; "char" "finally" "long" "strictfp" "volatile"
|
||||
; "class" "float" "native" "super" "while"
|
||||
; "const" "for" "new" "switch"
|
||||
; "continue" "goto" "package" "synchronized"))
|
||||
;
|
||||
; ;; 3.10.1
|
||||
; (Digits (re:+ (re:/ "09")))
|
||||
; (DigitsOpt (re:* (re:/ "09")))
|
||||
;
|
||||
; (IntegerTypeSuffix (char-set "lL"))
|
||||
; (DecimalNumeral (re:or #\0
|
||||
; (re:: (re:/ "19") (re:* (re:/ "09")))))
|
||||
; (HexDigit (re:/ "09" "af" "AF"))
|
||||
; (HexNumeral (re:: #\0 (char-set "xX") (re:+ HexDigit)))
|
||||
; (OctalNumeral (re:: #\0 (re:+ (re:/ "07"))))
|
||||
;
|
||||
; ;; 3.10.2
|
||||
; (FloatTypeSuffix (char-set "fF"))
|
||||
; (DoubleTypeSuffix (char-set "dD"))
|
||||
;
|
||||
; (FloatA (re:: Digits #\. DigitsOpt (re:? ExponentPart)))
|
||||
; (FloatB (re:: #\. Digits (re:? ExponentPart)))
|
||||
; (FloatC (re:: Digits ExponentPart))
|
||||
; (FloatD (re:: Digits (re:? ExponentPart)))
|
||||
;
|
||||
; (ExponentPart (re:: (char-set "eE") (re:? (char-set "+-")) Digits))
|
||||
;
|
||||
; ;; MORE
|
||||
;
|
||||
; ;; 3.10.6
|
||||
; (EscapeSequence (re:or "\\b" "\\t" "\\n" "\\f" "\\r" "\\\"" "\\'" "\\\\"
|
||||
; (re:: #\\ (re:? (re:/ "03")) (re:/ "07") (re:/ "07"))
|
||||
; (re:: #\\ (re:/ "07"))))
|
||||
;
|
||||
; ;; 3.12
|
||||
; (Operator (re:or "=" ">" "<" "!" "~" "?" ":"
|
||||
; "==" "<=" ">=" "!=" "&&" "||" "++" "--"
|
||||
; "+" "-" "*" "/" "&" "|" "^" "%" "<<" ">>" ">>>"
|
||||
; "+=" "-=" "*=" "/=" "&=" "|=" "^=" "%=" "<<=" ">>=" ">>>=")))
|
||||
;
|
||||
; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; ;;Comment lexers
|
||||
;
|
||||
; (define read-line-comment
|
||||
; (lexer
|
||||
; [(re:~ #\newline) (read-line-comment input-port)]
|
||||
; [#\newline end-pos]
|
||||
; [(eof) end-pos]
|
||||
; [(special) (read-line-comment input-port)]
|
||||
; [(special-comment) (read-line-comment input-port)]
|
||||
; ))
|
||||
;
|
||||
; (define read-block-comment
|
||||
; (lexer
|
||||
; ["*/" end-pos]
|
||||
; [(eof) end-pos]
|
||||
; [(re:or "*" "/" (complement (re:: any-string (re:or "*" "/") any-string))) (read-block-comment input-port)]
|
||||
; [(special) (read-block-comment input-port)]
|
||||
; [(special-comment) (read-block-comment input-port)]
|
||||
; ))
|
||||
;
|
||||
; #;(define read-document-comment
|
||||
; (lexer
|
||||
; ["**/" end-pos]
|
||||
; [(eof) end-pos]
|
||||
; [(re:or "*" "/" (~ (any-string))) (read-document-comment input-port)]
|
||||
; [(special) (read-document-comment input-port)]
|
||||
; [(special-comment) (read-document-comment input-port)]
|
||||
; [(special-error) (read-document-comment input-port)]))
|
||||
;
|
||||
; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; ;String lexer
|
||||
;
|
||||
; ;get-string: input-port -> (U STRING_LIT STRING_ERROR tokens)
|
||||
; (define (get-string input-port)
|
||||
; (letrec ((tokens (get-string-tokens input-port))
|
||||
; (last-token (list-ref tokens (sub1 (length tokens))))
|
||||
; (tokens->string
|
||||
; (lambda (toks)
|
||||
; ;Stops before the last element, which does not have a string
|
||||
; (if (null? (cdr toks))
|
||||
; ""
|
||||
; (string-append (string (token-value (position-token-token (car toks))))
|
||||
; (tokens->string (cdr toks)))))))
|
||||
; (if (eq? 'STRING_END (token-name (position-token-token last-token)))
|
||||
; (token-STRING_LIT (list (tokens->string tokens) (position-token-end-pos last-token)))
|
||||
; (token-STRING_ERROR
|
||||
; (list (tokens->string tokens)
|
||||
; (position-token-end-pos last-token)
|
||||
; (position-token-token last-token))))))
|
||||
;
|
||||
; ;get-string-tokens: input-port -> (list position-token)
|
||||
; (define (get-string-tokens input-port)
|
||||
; (let ((tok (get-str-tok input-port)))
|
||||
; (case (token-name (position-token-token tok))
|
||||
; ((STRING_EOF STRING_END STRING_NEWLINE) (list tok))
|
||||
; (else (cons tok (get-string-tokens input-port))))))
|
||||
;
|
||||
; (define-tokens str-tok (STRING_CHAR))
|
||||
; (define-empty-tokens err (STRING_END STRING_EOF STRING_NEWLINE))
|
||||
;
|
||||
; (define get-str-tok
|
||||
; (lexer-src-pos
|
||||
; (#\" (token-STRING_END))
|
||||
; (EscapeSequence (token-STRING_CHAR (EscapeSequence->char lexeme)))
|
||||
; (InputCharacter (token-STRING_CHAR (string-ref lexeme 0)))
|
||||
; ((re:or CR LF) (token-STRING_NEWLINE))
|
||||
; (#\032 (token-STRING_EOF))
|
||||
; ((eof) (token-STRING_EOF))))
|
||||
;
|
||||
; ;; 3.10.6
|
||||
; (define (EscapeSequence->char es)
|
||||
; (cond
|
||||
; ((string=? es "\\b") #\010)
|
||||
; ((string=? es "\\t") #\011)
|
||||
; ((string=? es "\\n") #\012)
|
||||
; ((string=? es "\\f") #\014)
|
||||
; ((string=? es "\\r") #\015)
|
||||
; ((string=? es "\\\"") #\")
|
||||
; ((string=? es "\\'") #\')
|
||||
; ((string=? es "\\\\") #\\)
|
||||
; (else (integer->char (string->number (trim-string es 1 0) 8)))))
|
||||
;
|
||||
; (define get-token
|
||||
; (lexer-src-pos
|
||||
; ;; 3.12
|
||||
; (Operator (let ((l lexeme))
|
||||
; (cond
|
||||
; ((string=? l "|") (token-PIPE))
|
||||
; ((string=? l "||") (token-OR))
|
||||
; ((string=? l "|=") (token-OREQUAL))
|
||||
; ((string=? l "=") (token-EQUAL))
|
||||
; ((string=? l "<") (token-LT))
|
||||
; ((string=? l ">") (token-GT))
|
||||
; ((string=? l "<=") (token-LTEQ))
|
||||
; ((string=? l ">=") (token-GTEQ))
|
||||
; ((string=? l "+") (token-PLUS))
|
||||
; ((string=? l "-") (token-MINUS))
|
||||
; ((string=? l "*") (token-TIMES))
|
||||
; ((string=? l "/") (token-DIVIDE))
|
||||
; ((string=? l "^") (token-^T))
|
||||
; (else (string->symbol l)))))
|
||||
;
|
||||
; ("->" (string->symbol lexeme))
|
||||
; ("->>" (string->symbol lexeme))
|
||||
; ("->>>" (string->symbol lexeme))
|
||||
;
|
||||
; ;; 3.11
|
||||
; ("(" (token-O_PAREN))
|
||||
; (")" (token-C_PAREN))
|
||||
; ("{" (token-O_BRACE))
|
||||
; ("}" (token-C_BRACE))
|
||||
; ("[" (token-O_BRACKET))
|
||||
; ("]" (token-C_BRACKET))
|
||||
; (";" (token-SEMI_COLON))
|
||||
; ("," (token-COMMA))
|
||||
; ("." (token-PERIOD))
|
||||
;
|
||||
; ;; 3.10.7
|
||||
; ("null" (token-NULL_LIT))
|
||||
;
|
||||
; ;; 3.10.5
|
||||
; (#\" (get-string input-port))
|
||||
; ;(token-STRING_LIT (list->string (get-string input-port))))
|
||||
;
|
||||
; ;; 3.10.4
|
||||
; ((re:: #\' (re:~ CR LF #\' #\\) #\')
|
||||
; (token-CHAR_LIT (string-ref lexeme 1)))
|
||||
; ((re:: #\' EscapeSequence #\')
|
||||
; (token-CHAR_LIT (EscapeSequence->char
|
||||
; (trim-string lexeme 1 1))))
|
||||
;
|
||||
; ;; 3.10.3
|
||||
; ("true" (token-TRUE_LIT))
|
||||
; ("false" (token-FALSE_LIT))
|
||||
;
|
||||
; ;; 3.10.2
|
||||
; ((re:or FloatA FloatB FloatC)
|
||||
; (token-DOUBLE_LIT (string->number lexeme)))
|
||||
; ((re:: (re:or FloatA FloatB FloatC FloatD) FloatTypeSuffix)
|
||||
; (token-FLOAT_LIT (string->number (trim-string lexeme 0 1))))
|
||||
; ((re:: (re:or FloatA FloatB FloatC FloatD) DoubleTypeSuffix)
|
||||
; (token-DOUBLE_LIT (string->number (trim-string lexeme 0 1))))
|
||||
;
|
||||
;
|
||||
; ;; 3.10.1
|
||||
; (DecimalNumeral
|
||||
; (token-INTEGER_LIT (string->number lexeme 10)))
|
||||
; ((re:: DecimalNumeral IntegerTypeSuffix)
|
||||
; (token-LONG_LIT (string->number (trim-string lexeme 0 1) 10)))
|
||||
; ((re:: HexNumeral IntegerTypeSuffix)
|
||||
; (token-HEXL_LIT (string->number (trim-string lexeme 2 1) 16)))
|
||||
; (HexNumeral
|
||||
; (token-HEX_LIT (string->number (trim-string lexeme 2 0) 16)))
|
||||
; (OctalNumeral
|
||||
; (token-OCT_LIT (string->number (trim-string lexeme 1 0) 8)))
|
||||
; ((re:: OctalNumeral IntegerTypeSuffix)
|
||||
; (token-OCTL_LIT (string->number (trim-string lexeme 1 1) 8)))
|
||||
;
|
||||
; #;("dynamic"
|
||||
; (cond
|
||||
; ((dynamic?) (string->symbol lexeme))
|
||||
; (else (token-IDENTIFIER lexeme))))
|
||||
;
|
||||
; #;((re:or "check" "expect" "within")
|
||||
; (cond
|
||||
; ((test-ext?) (string->symbol lexeme))
|
||||
; (else (token-IDENTIFIER lexeme))))
|
||||
;
|
||||
; #;((re:or "test" "tests" "testcase")
|
||||
; (cond
|
||||
; ((testcase-ext?) (string->symbol lexeme))
|
||||
; (else (token-IDENTIFIER lexeme))))
|
||||
;
|
||||
; ;; 3.9
|
||||
; (Keyword (string->symbol lexeme))
|
||||
;
|
||||
; ;; 3.8
|
||||
; (Identifier (token-IDENTIFIER lexeme))
|
||||
;
|
||||
; ;; 3.7
|
||||
; ("//" (begin (read-line-comment input-port) (return-without-pos (get-token input-port))))
|
||||
; ("/*" (begin (read-block-comment input-port) (return-without-pos (get-token input-port))))
|
||||
; #;("/**" (begin (read-document-comment input-port) (return-without-pos (get-token input-port))))
|
||||
;
|
||||
; #;((special)
|
||||
; (cond
|
||||
; ((and (syntax? lexeme) (syntax-property lexeme 'test-case-box))
|
||||
; (token-TEST_SUITE (make-test-case lexeme)))
|
||||
; ((and (syntax? lexeme) (syntax-property lexeme 'example-box))
|
||||
; (syntax-case lexeme ()
|
||||
; ((parse-example-box examples) (token-EXAMPLE (make-example-box (syntax examples))))))
|
||||
; ((is-a? lexeme (image-snip%))
|
||||
; (token-IMAGE_SPECIAL lexeme))
|
||||
; (else
|
||||
; (token-OTHER_SPECIAL (list lexeme start-pos end-pos)))))
|
||||
;
|
||||
; ;; 3.6
|
||||
; ((re:+ WhiteSpace) (return-without-pos (get-token input-port)))
|
||||
;
|
||||
; ;; 3.5
|
||||
; (#\032 'EOF)
|
||||
; ((eof) 'EOF)
|
||||
;
|
||||
; ((re:+ (re:/ "09" "az" "AZ")) (token-NUMBER_ERROR lexeme))
|
||||
;
|
||||
; ))
|
||||
;
|
||||
|
||||
; (define-values/invoke-unit java-definitions-parsers@
|
||||
; (import)
|
||||
; (export (prefix def: parsers^) (prefix def: err^) token-proc^))
|
||||
;
|
||||
; (define-values/invoke-unit java-interactions-parsers@
|
||||
; (import)
|
||||
; (export (prefix int: parsers^) (prefix int: err^)))
|
||||
|
||||
(define-values/invoke-unit beginner-definitions-parser@
|
||||
(import)
|
||||
(export (prefix beginner-def: parsers^) (prefix beginner-def: err^) token-proc^))
|
||||
|
|
@ -359,17 +36,11 @@
|
|||
(define-values/invoke-unit advanced-interactions-parsers@
|
||||
(import)
|
||||
(export (prefix advanced-int: parsers^) (prefix advanced-int: err^) ))
|
||||
|
||||
|
||||
(define (parse parser err? err-src err-msg)
|
||||
(lambda (program-stream location)
|
||||
(let ([output
|
||||
;(with-handlers ((exn?
|
||||
; (lambda (e)
|
||||
; (string-append "parse function failed with this internal exception:"
|
||||
; (exn-message e)))))
|
||||
(!!! ((!!! parser) (old-tokens->new program-stream) location))]);)])
|
||||
(if (err? output) (list (err-msg output) (!!! (err-src output)))))))
|
||||
(let ([output (parser (old-tokens->new program-stream) location)])
|
||||
(and (err? output) (list (err-msg output) (err-src output))))))
|
||||
|
||||
(define parse-beginner (parse beginner-def:parse-program
|
||||
beginner-def:err? beginner-def:err-msg beginner-def:err-src))
|
||||
|
|
@ -385,8 +56,5 @@
|
|||
intermediate-int:err? intermediate-int:err-msg intermediate-int:err-src))
|
||||
(define parse-advanced-interact (parse advanced-int:parse-program
|
||||
advanced-int:err? advanced-int:err-msg advanced-int:err-src))
|
||||
|
||||
|
||||
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -310,6 +310,12 @@
|
|||
(build-src 2))])
|
||||
|
||||
(ExplicitConstructorInvocation
|
||||
[(this O_PAREN ArgumentList C_PAREN SEMI_COLON)
|
||||
(make-call #f (build-src 5)
|
||||
#f (make-special-name #f (build-src 1) "this") (reverse $3) #f)]
|
||||
[(this O_PAREN C_PAREN SEMI_COLON)
|
||||
(make-call #f (build-src 4)
|
||||
#f (make-special-name #f (build-src 1) "this") null #f)]
|
||||
[(super O_PAREN ArgumentList C_PAREN SEMI_COLON)
|
||||
(make-call #f (build-src 5)
|
||||
#f (make-special-name #f (build-src 1) "super") (reverse $3) #f)]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user