diff --git a/collects/combinator-parser/private-combinator/combinator-parser.scm b/collects/combinator-parser/private-combinator/combinator-parser.scm index 5b91f3dc5c..381396bb31 100644 --- a/collects/combinator-parser/private-combinator/combinator-parser.scm +++ b/collects/combinator-parser/private-combinator/combinator-parser.scm @@ -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^) diff --git a/collects/combinator-parser/private-combinator/combinator.scm b/collects/combinator-parser/private-combinator/combinator.scm index 4b5aa67807..e4cc37b962 100644 --- a/collects/combinator-parser/private-combinator/combinator.scm +++ b/collects/combinator-parser/private-combinator/combinator.scm @@ -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*)) ) diff --git a/collects/combinator-parser/private-combinator/errors.scm b/collects/combinator-parser/private-combinator/errors.scm index 92e26e318d..eca4ec8b22 100644 --- a/collects/combinator-parser/private-combinator/errors.scm +++ b/collects/combinator-parser/private-combinator/errors.scm @@ -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)] diff --git a/collects/combinator-parser/private-combinator/parser-sigs.ss b/collects/combinator-parser/private-combinator/parser-sigs.ss index 9fa0d40f27..f33bb4bb8c 100644 --- a/collects/combinator-parser/private-combinator/parser-sigs.ss +++ b/collects/combinator-parser/private-combinator/parser-sigs.ss @@ -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)) diff --git a/collects/combinator-parser/private-combinator/structs.scm b/collects/combinator-parser/private-combinator/structs.scm index 3a009d9890..8543d1ed12 100644 --- a/collects/combinator-parser/private-combinator/structs.scm +++ b/collects/combinator-parser/private-combinator/structs.scm @@ -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)) diff --git a/collects/profj/comb-parsers/java-signatures.scm b/collects/profj/comb-parsers/java-signatures.scm index a8396dba84..bb68a465b6 100644 --- a/collects/profj/comb-parsers/java-signatures.scm +++ b/collects/profj/comb-parsers/java-signatures.scm @@ -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^) -; -; ) -; diff --git a/collects/profj/comb-parsers/parser-units.scm b/collects/profj/comb-parsers/parser-units.scm index 2426062504..aac68d1763 100644 --- a/collects/profj/comb-parsers/parser-units.scm +++ b/collects/profj/comb-parsers/parser-units.scm @@ -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 diff --git a/collects/profj/comb-parsers/parsers.scm b/collects/profj/comb-parsers/parsers.scm index 819a4493ff..7984f1ed34 100644 --- a/collects/profj/comb-parsers/parsers.scm +++ b/collects/profj/comb-parsers/parsers.scm @@ -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)) - - - ) diff --git a/collects/profj/parsers/intermediate-access-parser.ss b/collects/profj/parsers/intermediate-access-parser.ss index 20dc2faa7b..590c478044 100644 --- a/collects/profj/parsers/intermediate-access-parser.ss +++ b/collects/profj/parsers/intermediate-access-parser.ss @@ -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)]