mbutterick
/
brag
1
0
Fork 0
Code Issues 3 Pull Requests 1 Projects Releases Wiki Activity

Use `struct` instead of `define-struct`

Browse Source
remotes/jackfirth/master
Jack Firth 3 years ago
parent 121c26450e
commit 9c78ffcc05
17 changed files with 207 additions and 208 deletions
Show Stats Download Patch File Download Diff File

132
parser-tools/cfg-parser.rkt
Unescape Escape View File

@ -41,10 +41,10 @@
(provide cfg-parser) (provide cfg-parser)
;; A raw token, wrapped so that we can recognize it: ;; A raw token, wrapped so that we can recognize it:
(define-struct tok (name orig-name val start end)) (struct tok (name orig-name val start end))
;; Represents the thread scheduler: ;; Represents the thread scheduler:
(define-struct tasks (active active-back waits multi-waits cache progress?)) (struct tasks (active active-back waits multi-waits cache progress?))
(define-for-syntax make-token-identifier-mapping make-hasheq) (define-for-syntax make-token-identifier-mapping make-hasheq)
(define-for-syntax (token-identifier-mapping-get t tok [fail #f]) (define-for-syntax (token-identifier-mapping-get t tok [fail #f])
@ -187,50 +187,50 @@
max-depth tasks)) max-depth tasks))
;; Starts a thread ;; Starts a thread
(define (queue-task tasks t [progress? #t]) (define (queue-task ts t [progress? #t])
(make-tasks (tasks-active tasks) (tasks (tasks-active ts)
(cons t (tasks-active-back tasks)) (cons t (tasks-active-back ts))
(tasks-waits tasks) (tasks-waits ts)
(tasks-multi-waits tasks) (tasks-multi-waits ts)
(tasks-cache tasks) (tasks-cache ts)
(or progress? (tasks-progress? tasks)))) (or progress? (tasks-progress? ts))))
;; Reports an answer to a waiting thread: ;; Reports an answer to a waiting thread:
(define (report-answer answer-key max-depth tasks val) (define (report-answer answer-key max-depth ts val)
(define v (hash-ref (tasks-waits tasks) answer-key (λ () #f))) (define v (hash-ref (tasks-waits ts) answer-key (λ () #f)))
(if v (if v
(let ([tasks (make-tasks (cons (v val) (tasks-active tasks)) (let ([ts (tasks (cons (v val) (tasks-active ts))
(tasks-active-back tasks) (tasks-active-back ts)
(tasks-waits tasks) (tasks-waits ts)
(tasks-multi-waits tasks) (tasks-multi-waits ts)
(tasks-cache tasks) (tasks-cache ts)
#t)]) #t)])
(hash-remove! (tasks-waits tasks) answer-key) (hash-remove! (tasks-waits ts) answer-key)
(swap-task max-depth tasks)) (swap-task max-depth ts))
;; We have an answer ready too fast; wait ;; We have an answer ready too fast; wait
(swap-task max-depth (swap-task max-depth
(queue-task tasks (queue-task ts
(λ (max-depth tasks) (λ (max-depth tasks)
(report-answer answer-key max-depth tasks val)) (report-answer answer-key max-depth tasks val))
#f)))) #f))))
;; Reports an answer to multiple waiting threads: ;; Reports an answer to multiple waiting threads:
(define (report-answer-all answer-key max-depth tasks val k) (define (report-answer-all answer-key max-depth ts val k)
(define v (hash-ref (tasks-multi-waits tasks) answer-key (λ () null))) (define v (hash-ref (tasks-multi-waits ts) answer-key (λ () null)))
(hash-remove! (tasks-multi-waits tasks) answer-key) (hash-remove! (tasks-multi-waits ts) answer-key)
(let ([tasks (make-tasks (append (map (λ (a) (a val)) v) (let ([ts (tasks (append (map (λ (a) (a val)) v)
(tasks-active tasks)) (tasks-active ts))
(tasks-active-back tasks) (tasks-active-back ts)
(tasks-waits tasks) (tasks-waits ts)
(tasks-multi-waits tasks) (tasks-multi-waits ts)
(tasks-cache tasks) (tasks-cache ts)
#t)]) #t)])
(k max-depth tasks))) (k max-depth ts)))
;; Waits for an answer; if `multi?' is #f, this is sole waiter, otherwise ;; Waits for an answer; if `multi?' is #f, this is sole waiter, otherwise
;; there might be many. Use wither #t or #f (and `report-answer' or ;; there might be many. Use wither #t or #f (and `report-answer' or
;; `report-answer-all', resptively) consistently for a particular answer key. ;; `report-answer-all', resptively) consistently for a particular answer key.
(define (wait-for-answer multi? max-depth tasks answer-key success-k fail-k deadlock-k) (define (wait-for-answer multi? max-depth ts answer-key success-k fail-k deadlock-k)
(let ([wait (λ (val) (let ([wait (λ (val)
(λ (max-depth tasks) (λ (max-depth tasks)
(if val (if val
@ -240,58 +240,58 @@
(success-k val stream last-consumed-token depth max-depth tasks next-k))) (success-k val stream last-consumed-token depth max-depth tasks next-k)))
(deadlock-k max-depth tasks))))]) (deadlock-k max-depth tasks))))])
(if multi? (if multi?
(hash-set! (tasks-multi-waits tasks) answer-key (hash-set! (tasks-multi-waits ts) answer-key
(cons wait (hash-ref (tasks-multi-waits tasks) answer-key (cons wait (hash-ref (tasks-multi-waits ts) answer-key
(λ () null)))) (λ () null))))
(hash-set! (tasks-waits tasks) answer-key wait)) (hash-set! (tasks-waits ts) answer-key wait))
(let ([tasks (make-tasks (tasks-active tasks) (let ([ts (tasks (tasks-active ts)
(tasks-active-back tasks) (tasks-active-back ts)
(tasks-waits tasks) (tasks-waits ts)
(tasks-multi-waits tasks) (tasks-multi-waits ts)
(tasks-cache tasks) (tasks-cache ts)
#t)]) #t)])
(swap-task max-depth tasks)))) (swap-task max-depth ts))))
;; Swap thread ;; Swap thread
(define (swap-task max-depth tasks) (define (swap-task max-depth ts)
;; Swap in first active: ;; Swap in first active:
(if (null? (tasks-active tasks)) (if (null? (tasks-active ts))
(if (tasks-progress? tasks) (if (tasks-progress? ts)
(swap-task max-depth (swap-task max-depth
(make-tasks (reverse (tasks-active-back tasks)) (tasks (reverse (tasks-active-back ts))
null null
(tasks-waits tasks) (tasks-waits ts)
(tasks-multi-waits tasks) (tasks-multi-waits ts)
(tasks-cache tasks) (tasks-cache ts)
#f)) #f))
;; No progress, so issue failure for all multi-waits ;; No progress, so issue failure for all multi-waits
(if (zero? (hash-count (tasks-multi-waits tasks))) (if (zero? (hash-count (tasks-multi-waits ts)))
(error 'swap-task "Deadlock") (error 'swap-task "Deadlock")
(swap-task max-depth (swap-task max-depth
(make-tasks (apply (tasks (apply
append append
(hash-map (tasks-multi-waits tasks) (hash-map (tasks-multi-waits ts)
(λ (k l) (λ (k l)
(map (λ (v) (v #f)) l)))) (map (λ (v) (v #f)) l))))
(tasks-active-back tasks) (tasks-active-back ts)
(tasks-waits tasks) (tasks-waits ts)
(make-hasheq) (make-hasheq)
(tasks-cache tasks) (tasks-cache ts)
#t)))) #t))))
(let ([t (car (tasks-active tasks))] (let ([t (car (tasks-active ts))]
[tasks (make-tasks (cdr (tasks-active tasks)) [ts (tasks (cdr (tasks-active ts))
(tasks-active-back tasks) (tasks-active-back ts)
(tasks-waits tasks) (tasks-waits ts)
(tasks-multi-waits tasks) (tasks-multi-waits ts)
(tasks-cache tasks) (tasks-cache ts)
(tasks-progress? tasks))]) (tasks-progress? ts))])
(t max-depth tasks)))) (t max-depth ts))))
;; Finds the symbolic representative of a token class ;; Finds the symbolic representative of a token class
(define-for-syntax (map-token toks tok) (define-for-syntax (map-token toks tok)
(car (token-identifier-mapping-get toks tok))) (car (token-identifier-mapping-get toks tok)))
(define no-pos-val (make-position #f #f #f)) (define no-pos-val (position #f #f #f))
(define-for-syntax no-pos (define-for-syntax no-pos
(let ([npv ((syntax-local-certifier) #'no-pos-val)]) (let ([npv ((syntax-local-certifier) #'no-pos-val)])
(λ (stx) npv))) (λ (stx) npv)))
@ -642,7 +642,7 @@
cfg-error cfg-error
src-pos? src-pos?
(list* (list*
(with-syntax ([((tok tok-id . $e) ...) (with-syntax ([((tk tok-id . $e) ...)
(token-identifier-mapping-map toks (token-identifier-mapping-map toks
(λ (k v) (λ (k v)
(list* k (list* k
@ -661,7 +661,7 @@
[%atok atok-id-temp]) [%atok atok-id-temp])
#`(grammar (%start [() null] #`(grammar (%start [() null]
[(%atok %start) (cons $1 $2)]) [(%atok %start) (cons $1 $2)])
(%atok [(tok) (make-tok 'tok-id 'tok $e pos ...)] ...))) (%atok [(tk) (tok 'tok-id 'tk $e pos ...)] ...)))
(with-syntax ([%start start-id-temp]) (with-syntax ([%start start-id-temp])
#`(start %start)) #`(start %start))
parser-clauses)))] parser-clauses)))]
@ -705,8 +705,8 @@
(error-proc #t (error-proc #t
'no-tokens 'no-tokens
#f #f
(make-position #f #f #f) (position #f #f #f)
(make-position #f #f #f)) (position #f #f #f))
(error (error
'cfg-parse 'cfg-parse
"no tokens"))] "no tokens"))]
@ -745,7 +745,7 @@
success-k success-k
fail-k fail-k
0 0
(make-tasks null null (tasks null null
(make-hasheq) (make-hasheq) (make-hasheq) (make-hasheq)
(make-hash) #t)))))))))])) (make-hash) #t)))))))))]))

10
parser-tools/lex.rkt
Unescape Escape View File

@ -44,12 +44,12 @@
#`(let/ec ret #`(let/ec ret
(syntax-parameterize (syntax-parameterize
([return-without-pos (make-rename-transformer #'ret)]) ([return-without-pos (make-rename-transformer #'ret)])
(make-position-token #,action start-pos end-pos)))] (position-token #,action start-pos end-pos)))]
[(eq? src-loc-style 'lexer-srcloc) [(eq? src-loc-style 'lexer-srcloc)
#`(let/ec ret #`(let/ec ret
(syntax-parameterize (syntax-parameterize
([return-without-srcloc (make-rename-transformer #'ret)]) ([return-without-srcloc (make-rename-transformer #'ret)])
(make-srcloc-token #,action lexeme-srcloc)))] (srcloc-token #,action lexeme-srcloc)))]
[else action])]) [else action])])
(syntax/loc action (syntax/loc action
(λ (start-pos-p end-pos-p lexeme-p input-port-p) (λ (start-pos-p end-pos-p lexeme-p input-port-p)
@ -151,7 +151,7 @@
[(_ NAME RE) (identifier? #'NAME) [(_ NAME RE) (identifier? #'NAME)
(syntax/loc stx (syntax/loc stx
(define-syntax NAME (define-syntax NAME
(make-lex-abbrev (λ () (quote-syntax RE)))))] (lex-abbrev (λ () (quote-syntax RE)))))]
[_ (raise-syntax-error 'define-lex-abbrev "form should be (define-lex-abbrev name re)" stx)])) [_ (raise-syntax-error 'define-lex-abbrev "form should be (define-lex-abbrev name re)" stx)]))
(define-syntax (define-lex-abbrevs stx) (define-syntax (define-lex-abbrevs stx)
@ -183,7 +183,7 @@
(raise-syntax-error 'define-lex-trans "expected a procedure as the transformer, got ~e" func)) (raise-syntax-error 'define-lex-trans "expected a procedure as the transformer, got ~e" func))
(unless (procedure-arity-includes? func 1) (unless (procedure-arity-includes? func 1)
(raise-syntax-error 'define-lex-trans "expected a procedure that accepts 1 argument as the transformer, got ~e" func)) (raise-syntax-error 'define-lex-trans "expected a procedure that accepts 1 argument as the transformer, got ~e" func))
(make-lex-trans func))))] (lex-trans func))))]
[_ [_
(raise-syntax-error (raise-syntax-error
#f #f
@ -305,7 +305,7 @@
(define (get-position ip) (define (get-position ip)
(define-values (line col off) (port-next-location ip)) (define-values (line col off) (port-next-location ip))
(make-position off line col)) (position off line col))
(define-syntax (create-unicode-abbrevs stx) (define-syntax (create-unicode-abbrevs stx)
(syntax-case stx () (syntax-case stx ()

26
parser-tools/private-lex/deriv.rkt
Unescape Escape View File

@ -179,8 +179,8 @@
((get-final b) 4)) ((get-final b) 4))
;; A state is (make-state (list-of re-action) nat) ;; A state is (state (list-of re-action) nat)
(define-struct state (spec index)) (struct state (spec index))
;; get->key : re-action -> (list-of nat) ;; get->key : re-action -> (list-of nat)
;; states are indexed by the list of indexes of their res ;; states are indexed by the list of indexes of their res
@ -205,20 +205,20 @@
(r1 (->re `(char-range #\1 #\4) c)) (r1 (->re `(char-range #\1 #\4) c))
(r2 (->re `(char-range #\2 #\3) c))) (r2 (->re `(char-range #\2 #\3) c)))
((compute-chars null) null) ((compute-chars null) null)
((compute-chars (list (make-state null 1))) null) ((compute-chars (list (state null 1))) null)
((map is:integer-set-contents ((map is:integer-set-contents
(compute-chars (list (make-state (list (cons r1 1) (cons r2 2)) 2)))) (compute-chars (list (state (list (cons r1 1) (cons r2 2)) 2))))
(list (is:integer-set-contents (is:make-range (c->i #\2) (c->i #\3))) (list (is:integer-set-contents (is:make-range (c->i #\2) (c->i #\3)))
(is:integer-set-contents (is:union (is:make-range (c->i #\1)) (is:integer-set-contents (is:union (is:make-range (c->i #\1))
(is:make-range (c->i #\4))))))) (is:make-range (c->i #\4)))))))
;; A dfa is (make-dfa int int ;; A dfa is (dfa int int
;; (list-of (cons int syntax-object)) ;; (list-of (cons int syntax-object))
;; (list-of (cons int (list-of (cons char-set int))))) ;; (list-of (cons int (list-of (cons char-set int)))))
;; Each transitions is a state and a list of chars with the state to transition to. ;; Each transitions is a state and a list of chars with the state to transition to.
;; The finals and transitions are sorted by state number, and duplicate free. ;; The finals and transitions are sorted by state number, and duplicate free.
(define-struct dfa (num-states start-state final-states/actions transitions) #:inspector (make-inspector)) (struct dfa (num-states start-state final-states/actions transitions) #:inspector (make-inspector))
(define loc:get-integer is:get-integer) (define loc:get-integer is:get-integer)
@ -226,7 +226,7 @@
(define (build-dfa rs cache) (define (build-dfa rs cache)
(let* ([transitions (make-hash)] (let* ([transitions (make-hash)]
[get-state-number (make-counter)] [get-state-number (make-counter)]
[start (make-state rs (get-state-number))]) [start (state rs (get-state-number))])
(cache (cons 'state (get-key rs)) (λ () start)) (cache (cons 'state (get-key rs)) (λ () start))
(let loop ([old-states (list start)] (let loop ([old-states (list start)]
[new-states null] [new-states null]
@ -234,7 +234,7 @@
[cs (compute-chars (list start))]) [cs (compute-chars (list start))])
(cond (cond
[(and (null? old-states) (null? new-states)) [(and (null? old-states) (null? new-states))
(make-dfa (get-state-number) (state-index start) (dfa (get-state-number) (state-index start)
(sort (for*/list ([state (in-list all-states)] (sort (for*/list ([state (in-list all-states)]
[val (in-value (cons (state-index state) (get-final (state-spec state))))] [val (in-value (cons (state-index state) (get-final (state-spec state))))]
#:when (cdr val)) #:when (cdr val))
@ -252,21 +252,21 @@
[(null? cs) [(null? cs)
(loop (cdr old-states) new-states all-states (compute-chars (cdr old-states)))] (loop (cdr old-states) new-states all-states (compute-chars (cdr old-states)))]
[else [else
(define state (car old-states)) (define s (car old-states))
(define c (car cs)) (define c (car cs))
(define new-re (derive (state-spec state) (loc:get-integer c) cache)) (define new-re (derive (state-spec s) (loc:get-integer c) cache))
(cond (cond
[new-re [new-re
(let* ([new-state? #f] (let* ([new-state? #f]
[new-state (cache (cons 'state (get-key new-re)) [new-state (cache (cons 'state (get-key new-re))
(λ () (λ ()
(set! new-state? #t) (set! new-state? #t)
(make-state new-re (get-state-number))))] (state new-re (get-state-number))))]
[new-all-states (if new-state? (cons new-state all-states) all-states)]) [new-all-states (if new-state? (cons new-state all-states) all-states)])
(hash-set! transitions (hash-set! transitions
state s
(cons (cons c new-state) (cons (cons c new-state)
(hash-ref transitions state (hash-ref transitions s
(λ () null)))) (λ () null))))
(cond (cond
[new-state? [new-state?

6
parser-tools/private-lex/front.rkt
Unescape Escape View File

@ -89,12 +89,12 @@
(vector-set! no-look (car trans) #f)) (vector-set! no-look (car trans) #f))
no-look) no-look)
(test-block ((d1 (make-dfa 1 1 (list) (list))) (test-block ((d1 (dfa 1 1 (list) (list)))
(d2 (make-dfa 4 1 (list (cons 2 2) (cons 3 3)) (d2 (dfa 4 1 (list (cons 2 2) (cons 3 3))
(list (cons 1 (list (cons (is:make-range 49 50) 1) (list (cons 1 (list (cons (is:make-range 49 50) 1)
(cons (is:make-range 51) 2))) (cons (is:make-range 51) 2)))
(cons 2 (list (cons (is:make-range 49) 3)))))) (cons 2 (list (cons (is:make-range 49) 3))))))
(d3 (make-dfa 4 1 (list (cons 2 2) (cons 3 3)) (d3 (dfa 4 1 (list (cons 2 2) (cons 3 3))
(list (cons 1 (list (cons (is:make-range 100 200) 0) (list (cons 1 (list (cons (is:make-range 100 200) 0)
(cons (is:make-range 49 50) 1) (cons (is:make-range 49 50) 1)
(cons (is:make-range 51) 2))) (cons (is:make-range 51) 2)))

50
parser-tools/private-lex/re.rkt
Unescape Escape View File

@ -14,34 +14,34 @@
(define get-index (make-counter)) (define get-index (make-counter))
;; An re is either ;; An re is either
;; - (make-epsilonR bool nat) ;; - (epsilonR bool nat)
;; - (make-zeroR bool nat) ;; - (zeroR bool nat)
;; - (make-char-setR bool nat char-set) ;; - (char-setR bool nat char-set)
;; - (make-concatR bool nat re re) ;; - (concatR bool nat re re)
;; - (make-repeatR bool nat nat nat-or-+inf.0 re) ;; - (repeatR bool nat nat nat-or-+inf.0 re)
;; - (make-orR bool nat (list-of re)) Must not directly contain any orRs ;; - (orR bool nat (list-of re)) Must not directly contain any orRs
;; - (make-andR bool nat (list-of re)) Must not directly contain any andRs ;; - (andR bool nat (list-of re)) Must not directly contain any andRs
;; - (make-negR bool nat re) ;; - (negR bool nat re)
;; ;;
;; Every re must have an index field globally different from all ;; Every re must have an index field globally different from all
;; other re index fields. ;; other re index fields.
(define-struct re (nullable? index) #:inspector (make-inspector)) (struct re (nullable? index) #:inspector (make-inspector))
(define-struct (epsilonR re) () #:inspector (make-inspector)) (struct epsilonR re () #:inspector (make-inspector))
(define-struct (zeroR re) () #:inspector (make-inspector)) (struct zeroR re () #:inspector (make-inspector))
(define-struct (char-setR re) (chars) #:inspector (make-inspector)) (struct char-setR re (chars) #:inspector (make-inspector))
(define-struct (concatR re) (re1 re2) #:inspector (make-inspector)) (struct concatR re (re1 re2) #:inspector (make-inspector))
(define-struct (repeatR re) (low high re) #:inspector (make-inspector)) (struct repeatR re (low high re) #:inspector (make-inspector))
(define-struct (orR re) (res) #:inspector (make-inspector)) (struct orR re (res) #:inspector (make-inspector))
(define-struct (andR re) (res) #:inspector (make-inspector)) (struct andR re (res) #:inspector (make-inspector))
(define-struct (negR re) (re) #:inspector (make-inspector)) (struct negR re (re) #:inspector (make-inspector))
;; e : re ;; e : re
;; The unique epsilon re ;; The unique epsilon re
(define e (make-epsilonR #t (get-index))) (define e (epsilonR #t (get-index)))
;; z : re ;; z : re
;; The unique zero re ;; The unique zero re
(define z (make-zeroR #f (get-index))) (define z (zeroR #f (get-index)))
;; s-re = char constant ;; s-re = char constant
@ -145,7 +145,7 @@
[else [else
(cache l (cache l
(λ () (λ ()
(make-char-setR #f (get-index) cs)))])) (char-setR #f (get-index) cs)))]))
@ -158,7 +158,7 @@
[else [else
(cache (cons 'concat (cons (re-index r1) (re-index r2))) (cache (cons 'concat (cons (re-index r1) (re-index r2)))
(λ () (λ ()
(make-concatR (and (re-nullable? r1) (re-nullable? r2)) (concatR (and (re-nullable? r1) (re-nullable? r2))
(get-index) (get-index)
r1 r2)))])) r1 r2)))]))
@ -180,7 +180,7 @@
[else [else
(cache (cons 'repeat (cons low (cons high (re-index r)))) (cache (cons 'repeat (cons low (cons high (re-index r))))
(λ () (λ ()
(make-repeatR (or (re-nullable? r) (= 0 low)) (get-index) low high r)))]))) (repeatR (or (re-nullable? r) (= 0 low)) (get-index) low high r)))])))
;; build-or : (list-of re) cache -> re ;; build-or : (list-of re) cache -> re
@ -196,7 +196,7 @@
[else [else
(cache (cons 'or (map re-index rs)) (cache (cons 'or (map re-index rs))
(λ () (λ ()
(make-orR (ormap re-nullable? rs) (get-index) rs)))]))) (orR (ormap re-nullable? rs) (get-index) rs)))])))
;; build-and : (list-of re) cache -> re ;; build-and : (list-of re) cache -> re
(define (build-and rs cache) (define (build-and rs cache)
@ -208,7 +208,7 @@
[else [else
(cache (cons 'and (map re-index rs)) (cache (cons 'and (map re-index rs))
(λ () (λ ()
(make-andR (andmap re-nullable? rs) (get-index) rs)))]))) (andR (andmap re-nullable? rs) (get-index) rs)))])))
;; build-neg : re cache -> re ;; build-neg : re cache -> re
(define (build-neg r cache) (define (build-neg r cache)
@ -217,7 +217,7 @@
[else [else
(cache (cons 'neg (re-index r)) (cache (cons 'neg (re-index r))
(λ () (λ ()
(make-negR (not (re-nullable? r)) (get-index) r)))])) (negR (not (re-nullable? r)) (get-index) r)))]))
;; Tests for the build-functions ;; Tests for the build-functions
(test-block ((c (make-cache)) (test-block ((c (make-cache))

8
parser-tools/private-lex/token-syntax.rkt
Unescape Escape View File

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
(provide make-terminals-def terminals-def-t terminals-def? (provide terminals-def terminals-def-t terminals-def?
make-e-terminals-def e-terminals-def-t e-terminals-def?) e-terminals-def e-terminals-def-t e-terminals-def?)
;; The things needed at compile time to handle definition of tokens ;; The things needed at compile time to handle definition of tokens
(define-struct terminals-def (t)) (struct terminals-def (t))
(define-struct e-terminals-def (t)) (struct e-terminals-def (t))

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

@ -3,7 +3,7 @@
;; Defining tokens ;; Defining tokens
(provide define-tokens define-empty-tokens make-token token? (provide define-tokens define-empty-tokens token token?
(protect-out (rename-out [token-name real-token-name])) (protect-out (rename-out [token-name real-token-name]))
(protect-out (rename-out [token-value real-token-value])) (protect-out (rename-out [token-value real-token-value]))
(rename-out [token-name* token-name][token-value* token-value]) (rename-out [token-name* token-name][token-value* token-value])
@ -14,8 +14,8 @@
;; A token is either ;; A token is either
;; - symbol ;; - symbol
;; - (make-token symbol any) ;; - (token symbol any)
(define-struct token (name value) #:inspector (make-inspector)) (struct token (name value) #:inspector (make-inspector))
;; token-name*: token -> symbol ;; token-name*: token -> symbol
(define (token-name* t) (define (token-name* t)
@ -48,8 +48,8 @@
(begin (begin
(define-syntax NAME (define-syntax NAME
#,(if empty? #,(if empty?
#'(make-e-terminals-def (quote-syntax (marked-token ...))) #'(e-terminals-def (quote-syntax (marked-token ...)))
#'(make-terminals-def (quote-syntax (marked-token ...))))) #'(terminals-def (quote-syntax (marked-token ...)))))
#,@(map #,@(map
(λ (n) (λ (n)
(when (eq? (syntax-e n) 'error) (when (eq? (syntax-e n) 'error)
@ -61,7 +61,7 @@
#`(define (#,(make-ctor-name n)) #`(define (#,(make-ctor-name n))
'#,n) '#,n)
#`(define (#,(make-ctor-name n) x) #`(define (#,(make-ctor-name n) x)
(make-token '#,n x)))) (token '#,n x))))
(syntax->list #'(TOKEN ...))) (syntax->list #'(TOKEN ...)))
#;(define marked-token #f) #;...)))] #;(define marked-token #f) #;...)))]
[(_ ...) [(_ ...)
@ -72,9 +72,9 @@
(define-syntax define-tokens (make-define-tokens #f)) (define-syntax define-tokens (make-define-tokens #f))
(define-syntax define-empty-tokens (make-define-tokens #t)) (define-syntax define-empty-tokens (make-define-tokens #t))
(define-struct position (offset line col) #:inspector #f) (struct position (offset line col) #:inspector #f)
(define-struct position-token (token start-pos end-pos) #:inspector #f) (struct position-token (token start-pos end-pos) #:inspector #f)
(define-struct srcloc-token (token srcloc) #:inspector #f) (struct srcloc-token (token srcloc) #:inspector #f)

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

@ -5,8 +5,8 @@
(define max-char-num #x10FFFF) (define max-char-num #x10FFFF)
(define-struct lex-abbrev (get-abbrev)) (struct lex-abbrev (get-abbrev))
(define-struct lex-trans (f)) (struct lex-trans (f))
(module+ test (module+ test
(require rackunit)) (require rackunit))

24
parser-tools/private-yacc/grammar.rkt
Unescape Escape View File

@ -7,29 +7,29 @@
racket/contract) racket/contract)
;; Each production has a unique index 0 <= index <= number of productions ;; Each production has a unique index 0 <= index <= number of productions
(define-struct prod (lhs rhs index prec action) #:inspector (make-inspector) #:mutable) (struct prod (lhs rhs index prec action) #:inspector (make-inspector) #:mutable)
;; The dot-pos field is the index of the element in the rhs ;; The dot-pos field is the index of the element in the rhs
;; of prod that the dot immediately precedes. ;; of prod that the dot immediately precedes.
;; Thus 0 <= dot-pos <= (vector-length rhs). ;; Thus 0 <= dot-pos <= (vector-length rhs).
(define-struct item (prod dot-pos) #:inspector (make-inspector)) (struct item (prod dot-pos) #:inspector (make-inspector))
;; gram-sym = (union term? non-term?) ;; gram-sym = (union term? non-term?)
;; Each term has a unique index 0 <= index < number of terms ;; Each term has a unique index 0 <= index < number of terms
;; Each non-term has a unique index 0 <= index < number of non-terms ;; Each non-term has a unique index 0 <= index < number of non-terms
(define-struct term (sym index prec) #:inspector (make-inspector) #:mutable) (struct term (sym index prec) #:inspector (make-inspector) #:mutable)
(define-struct non-term (sym index) #:inspector (make-inspector) #:mutable) (struct non-term (sym index) #:inspector (make-inspector) #:mutable)
;; a precedence declaration. ;; a precedence declaration.
(define-struct prec (num assoc) #:inspector (make-inspector)) (struct prec (num assoc) #:inspector (make-inspector))
(provide/contract (provide/contract
[make-item (prod? (or/c #f natural-number/c) . -> . item?)] [item (prod? (or/c #f natural-number/c) . -> . item?)]
[make-term (symbol? (or/c #f natural-number/c) (or/c prec? #f) . -> . term?)] [term (symbol? (or/c #f natural-number/c) (or/c prec? #f) . -> . term?)]
[make-non-term (symbol? (or/c #f natural-number/c) . -> . non-term?)] [non-term (symbol? (or/c #f natural-number/c) . -> . non-term?)]
[make-prec (natural-number/c (or/c 'left 'right 'nonassoc) . -> . prec?)] [prec (natural-number/c (or/c 'left 'right 'nonassoc) . -> . prec?)]
[make-prod (non-term? (vectorof (or/c non-term? term?)) [prod (non-term? (vectorof (or/c non-term? term?))
(or/c #f natural-number/c) (or/c #f prec?) syntax? . -> . prod?)]) (or/c #f natural-number/c) (or/c #f prec?) syntax? . -> . prod?)])
(provide (provide
;; Things that work on items ;; Things that work on items
@ -73,7 +73,7 @@
(define (move-dot-right i) (define (move-dot-right i)
(cond (cond
[(= (item-dot-pos i) (vector-length (prod-rhs (item-prod i)))) #f] [(= (item-dot-pos i) (vector-length (prod-rhs (item-prod i)))) #f]
[else (make-item (item-prod i) [else (item (item-prod i)
(add1 (item-dot-pos i)))])) (add1 (item-dot-pos i)))]))
;; sym-at-dot: LR-item -> gram-sym | #f ;; sym-at-dot: LR-item -> gram-sym | #f

19
parser-tools/private-yacc/input-file-parser.rkt
Unescape Escape View File

@ -65,12 +65,12 @@
(for ([p-decl (in-list precs)]) (for ([p-decl (in-list precs)])
(define assoc (car p-decl)) (define assoc (car p-decl))
(for ([term-sym (in-list (cdr p-decl))]) (for ([term-sym (in-list (cdr p-decl))])
(hash-set! prec-table term-sym (make-prec counter assoc))) (hash-set! prec-table term-sym (prec counter assoc)))
(set! counter (add1 counter))) (set! counter (add1 counter)))
;; Build the terminal structures ;; Build the terminal structures
(for/list ([term-sym (in-list term-list)]) (for/list ([term-sym (in-list term-list)])
(make-term term-sym (term term-sym
#f #f
(hash-ref prec-table term-sym (λ () #f))))) (hash-ref prec-table term-sym (λ () #f)))))
@ -158,8 +158,7 @@
prec-decls)])) prec-decls)]))
(define terms (build-terms list-of-terms precs)) (define terms (build-terms list-of-terms precs))
(define non-terms (map (λ (non-term) (make-non-term non-term #f)) (define non-terms (map (λ (nt) (non-term nt #f)) list-of-non-terms))
list-of-non-terms))
(define term-table (make-hasheq)) (define term-table (make-hasheq))
(define non-term-table (make-hasheq)) (define non-term-table (make-hasheq))
@ -215,7 +214,7 @@
(syntax-case prod-so () (syntax-case prod-so ()
[(PROD-RHS ACTION) [(PROD-RHS ACTION)
(let ([p (parse-prod #'PROD-RHS)]) (let ([p (parse-prod #'PROD-RHS)])
(make-prod (prod
nt nt
p p
#f #f
@ -230,7 +229,7 @@
[(PROD-RHS (PREC TERM) ACTION) [(PROD-RHS (PREC TERM) ACTION)
(identifier? #'TERM) (identifier? #'TERM)
(let ([p (parse-prod #'PROD-RHS)]) (let ([p (parse-prod #'PROD-RHS)])
(make-prod (prod
nt nt
p p
#f #f
@ -269,18 +268,18 @@
(format "Start symbol ~a not defined as a non-terminal" ssym) (format "Start symbol ~a not defined as a non-terminal" ssym)
sstx)) sstx))
(define starts (map (λ (x) (make-non-term (gensym) #f)) start-syms)) (define starts (map (λ (x) (non-term (gensym) #f)) start-syms))
(define end-non-terms (map (λ (x) (make-non-term (gensym) #f)) start-syms)) (define end-non-terms (map (λ (x) (non-term (gensym) #f)) start-syms))
(define parsed-prods (map parse-prods-for-nt (syntax->list prods))) (define parsed-prods (map parse-prods-for-nt (syntax->list prods)))
(define start-prods (for/list ([start (in-list starts)] (define start-prods (for/list ([start (in-list starts)]
[end-non-term (in-list end-non-terms)]) [end-non-term (in-list end-non-terms)])
(list (make-prod start (vector end-non-term) #f #f #'values)))) (list (prod start (vector end-non-term) #f #f #'values))))
(define new-prods (define new-prods
(append start-prods (append start-prods
(for/list ([end-nt (in-list end-non-terms)] (for/list ([end-nt (in-list end-non-terms)]
[start-sym (in-list start-syms)]) [start-sym (in-list start-syms)])
(for/list ([end (in-list end-terms)]) (for/list ([end (in-list end-terms)])
(make-prod end-nt (prod end-nt
(vector (vector
(hash-ref non-term-table start-sym) (hash-ref non-term-table start-sym)
(hash-ref term-table end)) (hash-ref term-table end))

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

@ -24,7 +24,7 @@
(define r (send a run-automaton (trans-key-st tk) (trans-key-gs tk))) (define r (send a run-automaton (trans-key-st tk) (trans-key-gs tk)))
(for/list ([non-term (in-list nullable-non-terms)] (for/list ([non-term (in-list nullable-non-terms)]
#:when (send a run-automaton r non-term)) #:when (send a run-automaton r non-term))
(make-trans-key r non-term)))) (trans-key r non-term))))
;; compute-read: LR0-automaton * grammar -> (trans-key -> term set) ;; compute-read: LR0-automaton * grammar -> (trans-key -> term set)
;; output term set is represented in bit-vector form ;; output term set is represented in bit-vector form
@ -52,7 +52,7 @@
(define rhs (prod-rhs prod)) (define rhs (prod-rhs prod))
(define rhs-l (vector-length rhs)) (define rhs-l (vector-length rhs))
(append (if (and (> rhs-l 0) (eq? nt (vector-ref rhs (sub1 rhs-l)))) (append (if (and (> rhs-l 0) (eq? nt (vector-ref rhs (sub1 rhs-l))))
(list (make-item prod (sub1 rhs-l))) (list (item prod (sub1 rhs-l)))
null) null)
(let loop ([i (sub1 rhs-l)]) (let loop ([i (sub1 rhs-l)])
(cond (cond
@ -60,7 +60,7 @@
(non-term? (vector-ref rhs i)) (non-term? (vector-ref rhs i))
(send g nullable-non-term? (vector-ref rhs i))) (send g nullable-non-term? (vector-ref rhs i)))
(if (eq? nt (vector-ref rhs (sub1 i))) (if (eq? nt (vector-ref rhs (sub1 i)))
(cons (make-item prod (sub1 i)) (cons (item prod (sub1 i))
(loop (sub1 i))) (loop (sub1 i)))
(loop (sub1 i)))] (loop (sub1 i)))]
[else null])))) [else null]))))
@ -88,7 +88,7 @@
(define prod (item-prod item)) (define prod (item-prod item))
(define rhs (prod-rhs prod)) (define rhs (prod-rhs prod))
(define lhs (prod-lhs prod)) (define lhs (prod-lhs prod))
(map (λ (state) (make-trans-key state lhs)) (map (λ (state) (trans-key state lhs))
(run-lr0-backward a (run-lr0-backward a
rhs rhs
(item-dot-pos item) (item-dot-pos item)
@ -99,7 +99,7 @@
(define (compute-lookback a g) (define (compute-lookback a g)
(define num-states (send a get-num-states)) (define num-states (send a get-num-states))
(λ (state prod) (λ (state prod)
(map (λ (k) (make-trans-key k (prod-lhs prod))) (map (λ (k) (trans-key k (prod-lhs prod)))
(run-lr0-backward a (prod-rhs prod) (vector-length (prod-rhs prod)) state num-states)))) (run-lr0-backward a (prod-rhs prod) (vector-length (prod-rhs prod)) state num-states))))
;; compute-follow: LR0-automaton * grammar -> (trans-key -> term set) ;; compute-follow: LR0-automaton * grammar -> (trans-key -> term set)
@ -142,7 +142,7 @@
(λ (state) (λ (state)
(for-each (for-each
(λ (non-term) (λ (non-term)
(let ([res (f (make-trans-key state non-term))]) (let ([res (f (trans-key state non-term))])
(when (not (null? res)) (when (not (null? res))
(printf "~a(~a, ~a) = ~a\n" (printf "~a(~a, ~a) = ~a\n"
name name

36
parser-tools/private-yacc/lr0.rkt
Unescape Escape View File

@ -9,13 +9,13 @@
(struct-out trans-key) trans-key-list-remove-dups (struct-out trans-key) trans-key-list-remove-dups
kernel-items kernel-index) kernel-items kernel-index)
;; kernel = (make-kernel (LR1-item list) index) ;; kernel = (kernel (LR1-item list) index)
;; the list must be kept sorted according to item<? so that equal? can ;; the list must be kept sorted according to item<? so that equal? can
;; be used to compare kernels ;; be used to compare kernels
;; Each kernel is assigned a unique index, 0 <= index < number of states ;; Each kernel is assigned a unique index, 0 <= index < number of states
;; trans-key = (make-trans-key kernel gram-sym) ;; trans-key = (trans-key kernel gram-sym)
(define-struct kernel (items index) #:inspector (make-inspector)) (struct kernel (items index) #:inspector (make-inspector))
(define-struct trans-key (st gs) #:inspector (make-inspector)) (struct trans-key (st gs) #:inspector (make-inspector))
(define (trans-key<? a b) (define (trans-key<? a b)
(define kia (kernel-index (trans-key-st a))) (define kia (kernel-index (trans-key-st a)))
@ -63,7 +63,7 @@
(for ([trans-key/kernel (in-list assoc)]) (for ([trans-key/kernel (in-list assoc)])
(define tk (car trans-key/kernel)) (define tk (car trans-key/kernel))
(hash-table-add! reverse-hash (hash-table-add! reverse-hash
(make-trans-key (cdr trans-key/kernel) (trans-key (cdr trans-key/kernel)
(trans-key-gs tk)) (trans-key-gs tk))
(trans-key-st tk))) (trans-key-st tk)))
(hash-map reverse-hash cons)) (hash-map reverse-hash cons))
@ -167,7 +167,7 @@
(digraph (send grammar get-non-terms) (digraph (send grammar get-non-terms)
(λ (nt) (λ (nt)
(filter non-term? (filter non-term?
(map (λ (prod) (sym-at-dot (make-item prod 0))) (map (λ (prod) (sym-at-dot (item prod 0)))
(send grammar get-prods-for-non-term nt)))) (send grammar get-prods-for-non-term nt))))
(λ (nt) (list nt)) (λ (nt) (list nt))
(union non-term<?) (union non-term<?)
@ -189,7 +189,7 @@
[x (in-list (send grammar [x (in-list (send grammar
get-prods-for-non-term get-prods-for-non-term
non-term))]) non-term))])
(make-item x 0)) (item x 0))
(LR0-closure (cdr i))))] (LR0-closure (cdr i))))]
[else (cons (car i) (LR0-closure (cdr i)))])])) [else (cons (car i) (LR0-closure (cdr i)))])]))
@ -207,7 +207,7 @@
;; LR0-closure of kernel to the right, and grouping them by ;; LR0-closure of kernel to the right, and grouping them by
;; the term/non-term moved over. Returns the kernels not ;; the term/non-term moved over. Returns the kernels not
;; yet seen, and places the trans-keys into automaton ;; yet seen, and places the trans-keys into automaton
(define (goto kernel) (define (goto ker)
;; maps a gram-syms to a list of items ;; maps a gram-syms to a list of items
(define table (make-hasheq)) (define table (make-hasheq))
@ -222,12 +222,12 @@
(unless (member i already) (unless (member i already)
(hash-set! table (gram-sym-symbol gs) (cons i already)))] (hash-set! table (gram-sym-symbol gs) (cons i already)))]
((zero? (vector-length (prod-rhs (item-prod i)))) ((zero? (vector-length (prod-rhs (item-prod i))))
(define current (hash-ref epsilons kernel (λ () null))) (define current (hash-ref epsilons ker (λ () null)))
(hash-set! epsilons kernel (cons i current))))) (hash-set! epsilons ker (cons i current)))))
;; Group the items of the LR0 closure of the kernel ;; Group the items of the LR0 closure of the kernel
;; by the character after the dot ;; by the character after the dot
(for ([item (in-list (LR0-closure (kernel-items kernel)))]) (for ([item (in-list (LR0-closure (kernel-items ker)))])
(add-item! table item)) (add-item! table item))
;; each group is a new kernel, with the dot advanced. ;; each group is a new kernel, with the dot advanced.
@ -253,16 +253,16 @@
(define new-kernel (sort (filter values (map move-dot-right items)) item<?)) (define new-kernel (sort (filter values (map move-dot-right items)) item<?))
(define unique-kernel (hash-ref kernels new-kernel (define unique-kernel (hash-ref kernels new-kernel
(λ () (λ ()
(define k (make-kernel new-kernel counter)) (define k (kernel new-kernel counter))
(set! new #t) (set! new #t)
(set! counter (add1 counter)) (set! counter (add1 counter))
(hash-set! kernels new-kernel k) (hash-set! kernels new-kernel k)
k))) k)))
(if (term? gs) (if (term? gs)
(set! automaton-term (cons (cons (make-trans-key kernel gs) (set! automaton-term (cons (cons (trans-key ker gs)
unique-kernel) unique-kernel)
automaton-term)) automaton-term))
(set! automaton-non-term (cons (cons (make-trans-key kernel gs) (set! automaton-non-term (cons (cons (trans-key ker gs)
unique-kernel) unique-kernel)
automaton-non-term))) automaton-non-term)))
#;(printf "~a -> ~a on ~a\n" #;(printf "~a -> ~a on ~a\n"
@ -271,10 +271,10 @@
(gram-sym-symbol gs)) (gram-sym-symbol gs))
(and new unique-kernel)))) (and new unique-kernel))))
(define starts (map (λ (init-prod) (list (make-item init-prod 0))) (define starts (map (λ (init-prod) (list (item init-prod 0)))
(send grammar get-init-prods))) (send grammar get-init-prods)))
(define startk (for/list ([start (in-list starts)]) (define startk (for/list ([start (in-list starts)])
(define k (make-kernel start counter)) (define k (kernel start counter))
(hash-set! kernels start k) (hash-set! kernels start k)
(set! counter (add1 counter)) (set! counter (add1 counter))
k)) k))
@ -290,9 +290,9 @@
(enq! new-kernels (goto (car old-kernels))) (enq! new-kernels (goto (car old-kernels)))
(loop (cdr old-kernels) (cons (car old-kernels) seen-kernels))]))) (loop (cdr old-kernels) (cons (car old-kernels) seen-kernels))])))
(define-struct q (f l) #:inspector (make-inspector) #:mutable) (struct q (f l) #:inspector (make-inspector) #:mutable)
(define (empty-queue? q) (null? (q-f q))) (define (empty-queue? q) (null? (q-f q)))
(define (make-queue) (make-q null null)) (define (make-queue) (q null null))
(define (enq! q i) (define (enq! q i)
(cond (cond

34
parser-tools/private-yacc/parser-actions.rkt
Unescape Escape View File

@ -1,29 +1,29 @@
#lang racket/base #lang racket/base
(require yaragg/parser-tools/private-yacc/grammar) (require yaragg/parser-tools/private-yacc/grammar)
(provide (except-out (all-defined-out) make-reduce make-reduce*) (provide (except-out (all-defined-out) reduce reduce*)
(rename-out [make-reduce* make-reduce])) (rename-out [reduce* reduce]))
;; An action is ;; An action is
;; - (make-shift int) ;; - (shift int)
;; - (make-reduce prod runtime-action) ;; - (reduce prod runtime-action)
;; - (make-accept) ;; - (accept)
;; - (make-goto int) ;; - (goto int)
;; - (no-action) ;; - (no-action)
;; A reduce contains a runtime-reduce so that sharing of the reduces can ;; A reduce contains a runtime-reduce so that sharing of the reduces can
;; be easily transferred to sharing of runtime-reduces. ;; be easily transferred to sharing of runtime-reduces.
(define-struct action () #:inspector (make-inspector)) (struct action () #:inspector (make-inspector))
(define-struct (shift action) (state) #:inspector (make-inspector)) (struct shift action (state) #:inspector (make-inspector))
(define-struct (reduce action) (prod runtime-reduce) #:inspector (make-inspector)) (struct reduce action (prod runtime-reduce) #:inspector (make-inspector))
(define-struct (accept action) () #:inspector (make-inspector)) (struct accept action () #:inspector (make-inspector))
(define-struct (goto action) (state) #:inspector (make-inspector)) (struct goto action (state) #:inspector (make-inspector))
(define-struct (no-action action) () #:inspector (make-inspector)) (struct no-action action () #:inspector (make-inspector))
(define (make-reduce* p) (define (reduce* p)
(make-reduce p (reduce p
(vector (prod-index p) (vector (prod-index p)
(gram-sym-symbol (prod-lhs p)) (gram-sym-symbol (prod-lhs p))
(vector-length (prod-rhs p))))) (vector-length (prod-rhs p)))))
;; A runtime-action is ;; A runtime-action is
;; non-negative-int (shift) ;; non-negative-int (shift)

10
parser-tools/private-yacc/table.rkt
Unescape Escape View File

@ -121,7 +121,7 @@
;; resolve-conflict : (listof action?) -> action? bool bool ;; resolve-conflict : (listof action?) -> action? bool bool
(define (resolve-conflict actions) (define (resolve-conflict actions)
(cond (cond
[(null? actions) (values (make-no-action) #f #f)] [(null? actions) (values (no-action) #f #f)]
[(null? (cdr actions)) (values (car actions) #f #f)] [(null? (cdr actions)) (values (car actions) #f #f)]
[else [else
(define SR-conflict? (> (count shift? actions) 0)) (define SR-conflict? (> (count shift? actions) 0))
@ -221,11 +221,11 @@
(table-add! table from-state-index gs (table-add! table from-state-index gs
(cond (cond
((non-term? gs) ((non-term? gs)
(make-goto (kernel-index to-state))) (goto (kernel-index to-state)))
((member gs end-terms) ((member gs end-terms)
(make-accept)) (accept))
(else (else
(make-shift (shift
(kernel-index to-state)))))) (kernel-index to-state))))))
(send a for-each-state (send a for-each-state
(λ (state) (λ (state)
@ -239,7 +239,7 @@
(unless (start-item? item) (unless (start-item? item)
(let ((r (hash-ref reduce-cache item-prod (let ((r (hash-ref reduce-cache item-prod
(λ () (λ ()
(let ((r (make-reduce item-prod))) (let ((r (reduce item-prod)))
(hash-set! reduce-cache item-prod r) (hash-set! reduce-cache item-prod r)
r))))) r)))))
(table-add! table (table-add! table

14
parser-tools/yacc.rkt
Unescape Escape View File

@ -205,9 +205,9 @@
(define (extract-no-src-pos ip) (define (extract-no-src-pos ip)
(extract-helper ip #f #f)) (extract-helper ip #f #f))
(define-struct stack-frame (state value start-pos end-pos) #:inspector (make-inspector)) (struct stack-frame (state value start-pos end-pos) #:inspector (make-inspector))
(define (make-empty-stack i) (list (make-stack-frame i #f #f #f))) (define (make-empty-stack i) (list (stack-frame i #f #f #f)))
;; The table is a vector that maps each state to a hash-table that maps a ;; The table is a vector that maps each state to a hash-table that maps a
@ -230,7 +230,7 @@
(cond (cond
[(runtime-shift? a) [(runtime-shift? a)
;; (printf "shift:~a\n" (runtime-shift-state a)) ;; (printf "shift:~a\n" (runtime-shift-state a))
(cons (make-stack-frame (runtime-shift-state a) (cons (stack-frame (runtime-shift-state a)
val val
start-pos start-pos
end-pos) end-pos)
@ -247,7 +247,7 @@
;; (printf "shift:~a\n" (runtime-shift-state a)) ;; (printf "shift:~a\n" (runtime-shift-state a))
(set! stack (set! stack
(cons (cons
(make-stack-frame (runtime-shift-state a) (stack-frame (runtime-shift-state a)
#f #f
start-pos start-pos
end-pos) end-pos)
@ -283,7 +283,7 @@
(cond (cond
[(runtime-shift? action) [(runtime-shift? action)
;; (printf "shift:~a\n" (runtime-shift-state action)) ;; (printf "shift:~a\n" (runtime-shift-state action))
(parsing-loop (cons (make-stack-frame (runtime-shift-state action) (parsing-loop (cons (stack-frame (runtime-shift-state action)
val val
start-pos start-pos
end-pos) end-pos)
@ -304,14 +304,14 @@
(parsing-loop (parsing-loop
(cons (cons
(if src-pos (if src-pos
(make-stack-frame (stack-frame
goto goto
(apply (vector-ref actions (runtime-reduce-prod-num action)) args) (apply (vector-ref actions (runtime-reduce-prod-num action)) args)
(if (null? args) start-pos (cadr args)) (if (null? args) start-pos (cadr args))
(if (null? args) (if (null? args)
end-pos end-pos
(list-ref args (- (* (runtime-reduce-rhs-length action) 3) 1)))) (list-ref args (- (* (runtime-reduce-rhs-length action) 3) 1))))
(make-stack-frame (stack-frame
goto goto
(apply (vector-ref actions (runtime-reduce-prod-num action)) args) (apply (vector-ref actions (runtime-reduce-prod-num action)) args)
#f #f

6
rules/lexer.rkt
Unescape Escape View File

@ -133,9 +133,9 @@
(define-values (line-start col-start pos-start) (port-next-location ip)) (define-values (line-start col-start pos-start) (port-next-location ip))
(define str (read ip)) (define str (read ip))
(define-values (line-end col-end pos-end) (port-next-location ip)) (define-values (line-end col-end pos-end) (port-next-location ip))
(make-position-token (token-LIT (string-append "\"" str "\"")) (position-token (token-LIT (string-append "\"" str "\""))
(make-position pos-start line-start col-start) (position pos-start line-start col-start)
(make-position pos-end line-end col-end))) (position pos-end line-end col-end)))
(define (lex/1 ip) (define (lex/1 ip)
(match (peek-bytes 1 0 ip) (match (peek-bytes 1 0 ip)

6
yaragg-parser-tools.scrbl
Unescape Escape View File

@ -246,14 +246,14 @@ are a few examples, using @racket[:] prefixed SRE syntax:
@defform[(lexer-src-pos (trigger action-expr) ...)]{ @defform[(lexer-src-pos (trigger action-expr) ...)]{
Like @racket[lexer], but for each @racket[_action-result] produced by Like @racket[lexer], but for each @racket[_action-result] produced by
an @racket[action-expr], returns @racket[(make-position-token an @racket[action-expr], returns @racket[(position-token
_action-result start-pos end-pos)] instead of simply _action-result start-pos end-pos)] instead of simply
@racket[_action-result].} @racket[_action-result].}
@defform[(lexer-srcloc (trigger action-expr) ...)]{ @defform[(lexer-srcloc (trigger action-expr) ...)]{
Like @racket[lexer], but for each @racket[_action-result] produced by Like @racket[lexer], but for each @racket[_action-result] produced by
an @racket[action-expr], returns @racket[(make-srcloc-token an @racket[action-expr], returns @racket[(srcloc-token
_action-result lexeme-srcloc)] instead of simply _action-result lexeme-srcloc)] instead of simply
@racket[_action-result].} @racket[_action-result].}
@ -646,7 +646,7 @@ be the right choice when using @racket[lexer] in other situations.
@item{@racket[(src-pos)] @italic{OPTIONAL} @item{@racket[(src-pos)] @italic{OPTIONAL}
Causes the generated parser to expect input in the form Causes the generated parser to expect input in the form
@racket[(make-position-token _token _start-pos _end-pos)] instead @racket[(position-token _token _start-pos _end-pos)] instead
of simply @racket[_token]. Include this option when using the of simply @racket[_token]. Include this option when using the
parser with a lexer generated with @racket[lexer-src-pos].} parser with a lexer generated with @racket[lexer-src-pos].}

Write Preview
Loading…
Cancel
Save