refactor into racket/base
parent
fc1e00bc2a
commit
fd446e6013
@ -1,242 +1,240 @@
|
||||
#lang racket/base
|
||||
;; This implements the equivalent of racket's read-syntax for R5RS scheme.
|
||||
;; It has not been thoroughly tested. Also it will read an entire file into a
|
||||
;; list of syntax objects, instead of returning one syntax object at a time
|
||||
|
||||
(module read mzscheme
|
||||
|
||||
(require br-parser-tools/lex
|
||||
(prefix : br-parser-tools/lex-sre)
|
||||
br-parser-tools/yacc
|
||||
syntax/readerr)
|
||||
|
||||
(define-tokens data (DATUM))
|
||||
(define-empty-tokens delim (OP CP HASHOP QUOTE QUASIQUOTE UNQUOTE UNQUOTE-SPLICING DOT EOF))
|
||||
|
||||
(define scheme-lexer
|
||||
(lexer-src-pos
|
||||
|
||||
;; Skip comments, without accumulating extra position information
|
||||
[(:or scheme-whitespace comment) (return-without-pos (scheme-lexer input-port))]
|
||||
|
||||
["#t" (token-DATUM #t)]
|
||||
["#f" (token-DATUM #f)]
|
||||
[(:: "#\\" any-char) (token-DATUM (caddr (string->list lexeme)))]
|
||||
["#\\space" (token-DATUM #\space)]
|
||||
["#\\newline" (token-DATUM #\newline)]
|
||||
[(:or (:: initial (:* subsequent)) "+" "-" "...") (token-DATUM (string->symbol lexeme))]
|
||||
[#\" (token-DATUM (list->string (get-string-token input-port)))]
|
||||
[#\( 'OP]
|
||||
[#\) 'CP]
|
||||
[#\[ 'OP]
|
||||
[#\] 'CP]
|
||||
["#(" 'HASHOP]
|
||||
[num2 (token-DATUM (string->number lexeme 2))]
|
||||
[num8 (token-DATUM (string->number lexeme 8))]
|
||||
[num10 (token-DATUM (string->number lexeme 10))]
|
||||
[num16 (token-DATUM (string->number lexeme 16))]
|
||||
["'" 'QUOTE]
|
||||
["`" 'QUASIQUOTE]
|
||||
["," 'UNQUOTE]
|
||||
[",@" 'UNQUOTE-SPLICING]
|
||||
["." 'DOT]
|
||||
[(eof) 'EOF]))
|
||||
|
||||
(define get-string-token
|
||||
(lexer
|
||||
[(:~ #\" #\\) (cons (car (string->list lexeme))
|
||||
(get-string-token input-port))]
|
||||
[(:: #\\ #\\) (cons #\\ (get-string-token input-port))]
|
||||
[(:: #\\ #\") (cons #\" (get-string-token input-port))]
|
||||
[#\" null]))
|
||||
|
||||
|
||||
(define-lex-abbrevs
|
||||
[letter (:or (:/ "a" "z") (:/ #\A #\Z))]
|
||||
[digit (:/ #\0 #\9)]
|
||||
[scheme-whitespace (:or #\newline #\return #\tab #\space #\vtab)]
|
||||
[initial (:or letter (char-set "!$%&*/:<=>?^_~@"))]
|
||||
[subsequent (:or initial digit (char-set "+-.@"))]
|
||||
[comment (:: #\; (:* (:~ #\newline)) #\newline)]
|
||||
|
||||
|
||||
;; See ${PLTHOME}/collects/syntax-color/racket-lexer.rkt for an example of
|
||||
;; using regexp macros to avoid the cut and paste.
|
||||
; [numR (:: prefixR complexR)]
|
||||
; [complexR (:or realR
|
||||
; (:: realR "@" realR)
|
||||
; (:: realR "+" urealR "i")
|
||||
; (:: realR "-" urealR "i")
|
||||
; (:: realR "+i")
|
||||
; (:: realR "-i")
|
||||
; (:: "+" urealR "i")
|
||||
; (:: "-" urealR "i")
|
||||
; (:: "+i")
|
||||
; (:: "-i"))]
|
||||
; [realR (:: sign urealR)]
|
||||
; [urealR (:or uintegerR (:: uintegerR "/" uintegerR) decimalR)]
|
||||
; [uintegerR (:: (:+ digitR) (:* #\#))]
|
||||
; [prefixR (:or (:: radixR exactness)
|
||||
; (:: exactness radixR))]
|
||||
|
||||
[num2 (:: prefix2 complex2)]
|
||||
[complex2 (:or real2
|
||||
(:: real2 "@" real2)
|
||||
(:: real2 "+" ureal2 "i")
|
||||
(:: real2 "-" ureal2 "i")
|
||||
(:: real2 "+i")
|
||||
(:: real2 "-i")
|
||||
(:: "+" ureal2 "i")
|
||||
(:: "-" ureal2 "i")
|
||||
(require (for-syntax racket/base)
|
||||
br-parser-tools/lex
|
||||
(prefix-in : br-parser-tools/lex-sre)
|
||||
br-parser-tools/yacc
|
||||
syntax/readerr)
|
||||
|
||||
(define-tokens data (DATUM))
|
||||
(define-empty-tokens delim (OP CP HASHOP QUOTE QUASIQUOTE UNQUOTE UNQUOTE-SPLICING DOT EOF))
|
||||
|
||||
(define scheme-lexer
|
||||
(lexer-src-pos
|
||||
|
||||
;; Skip comments, without accumulating extra position information
|
||||
[(:or scheme-whitespace comment) (return-without-pos (scheme-lexer input-port))]
|
||||
|
||||
["#t" (token-DATUM #t)]
|
||||
["#f" (token-DATUM #f)]
|
||||
[(:: "#\\" any-char) (token-DATUM (caddr (string->list lexeme)))]
|
||||
["#\\space" (token-DATUM #\space)]
|
||||
["#\\newline" (token-DATUM #\newline)]
|
||||
[(:or (:: initial (:* subsequent)) "+" "-" "...") (token-DATUM (string->symbol lexeme))]
|
||||
[#\" (token-DATUM (list->string (get-string-token input-port)))]
|
||||
[#\( 'OP]
|
||||
[#\) 'CP]
|
||||
[#\[ 'OP]
|
||||
[#\] 'CP]
|
||||
["#(" 'HASHOP]
|
||||
[num2 (token-DATUM (string->number lexeme 2))]
|
||||
[num8 (token-DATUM (string->number lexeme 8))]
|
||||
[num10 (token-DATUM (string->number lexeme 10))]
|
||||
[num16 (token-DATUM (string->number lexeme 16))]
|
||||
["'" 'QUOTE]
|
||||
["`" 'QUASIQUOTE]
|
||||
["," 'UNQUOTE]
|
||||
[",@" 'UNQUOTE-SPLICING]
|
||||
["." 'DOT]
|
||||
[(eof) 'EOF]))
|
||||
|
||||
(define get-string-token
|
||||
(lexer
|
||||
[(:~ #\" #\\) (cons (car (string->list lexeme))
|
||||
(get-string-token input-port))]
|
||||
[(:: #\\ #\\) (cons #\\ (get-string-token input-port))]
|
||||
[(:: #\\ #\") (cons #\" (get-string-token input-port))]
|
||||
[#\" null]))
|
||||
|
||||
|
||||
(define-lex-abbrevs
|
||||
[letter (:or (:/ "a" "z") (:/ #\A #\Z))]
|
||||
[digit (:/ #\0 #\9)]
|
||||
[scheme-whitespace (:or #\newline #\return #\tab #\space #\vtab)]
|
||||
[initial (:or letter (char-set "!$%&*/:<=>?^_~@"))]
|
||||
[subsequent (:or initial digit (char-set "+-.@"))]
|
||||
[comment (:: #\; (:* (:~ #\newline)) #\newline)]
|
||||
|
||||
|
||||
;; See ${PLTHOME}/collects/syntax-color/racket-lexer.rkt for an example of
|
||||
;; using regexp macros to avoid the cut and paste.
|
||||
; [numR (:: prefixR complexR)]
|
||||
; [complexR (:or realR
|
||||
; (:: realR "@" realR)
|
||||
; (:: realR "+" urealR "i")
|
||||
; (:: realR "-" urealR "i")
|
||||
; (:: realR "+i")
|
||||
; (:: realR "-i")
|
||||
; (:: "+" urealR "i")
|
||||
; (:: "-" urealR "i")
|
||||
; (:: "+i")
|
||||
; (:: "-i"))]
|
||||
; [realR (:: sign urealR)]
|
||||
; [urealR (:or uintegerR (:: uintegerR "/" uintegerR) decimalR)]
|
||||
; [uintegerR (:: (:+ digitR) (:* #\#))]
|
||||
; [prefixR (:or (:: radixR exactness)
|
||||
; (:: exactness radixR))]
|
||||
|
||||
[num2 (:: prefix2 complex2)]
|
||||
[complex2 (:or real2
|
||||
(:: real2 "@" real2)
|
||||
(:: real2 "+" ureal2 "i")
|
||||
(:: real2 "-" ureal2 "i")
|
||||
(:: real2 "+i")
|
||||
(:: real2 "-i")
|
||||
(:: "+" ureal2 "i")
|
||||
(:: "-" ureal2 "i")
|
||||
(:: "+i")
|
||||
(:: "-i"))]
|
||||
[real2 (:: sign ureal2)]
|
||||
[ureal2 (:or uinteger2 (:: uinteger2 "/" uinteger2))]
|
||||
[uinteger2 (:: (:+ digit2) (:* #\#))]
|
||||
[prefix2 (:or (:: radix2 exactness)
|
||||
(:: exactness radix2))]
|
||||
[radix2 "#b"]
|
||||
[digit2 (:or "0" "1")]
|
||||
[num8 (:: prefix8 complex8)]
|
||||
[complex8 (:or real8
|
||||
(:: real8 "@" real8)
|
||||
(:: real8 "+" ureal8 "i")
|
||||
(:: real8 "-" ureal8 "i")
|
||||
(:: real8 "+i")
|
||||
(:: real8 "-i")
|
||||
(:: "+" ureal8 "i")
|
||||
(:: "-" ureal8 "i")
|
||||
(:: "+i")
|
||||
(:: "-i"))]
|
||||
[real8 (:: sign ureal8)]
|
||||
[ureal8 (:or uinteger8 (:: uinteger8 "/" uinteger8))]
|
||||
[uinteger8 (:: (:+ digit8) (:* #\#))]
|
||||
[prefix8 (:or (:: radix8 exactness)
|
||||
(:: exactness radix8))]
|
||||
[radix8 "#o"]
|
||||
[digit8 (:/ "0" "7")]
|
||||
|
||||
[num10 (:: prefix10 complex10)]
|
||||
[complex10 (:or real10
|
||||
(:: real10 "@" real10)
|
||||
(:: real10 "+" ureal10 "i")
|
||||
(:: real10 "-" ureal10 "i")
|
||||
(:: real10 "+i")
|
||||
(:: real10 "-i")
|
||||
(:: "+" ureal10 "i")
|
||||
(:: "-" ureal10 "i")
|
||||
(:: "+i")
|
||||
(:: "-i"))]
|
||||
[real2 (:: sign ureal2)]
|
||||
[ureal2 (:or uinteger2 (:: uinteger2 "/" uinteger2))]
|
||||
[uinteger2 (:: (:+ digit2) (:* #\#))]
|
||||
[prefix2 (:or (:: radix2 exactness)
|
||||
(:: exactness radix2))]
|
||||
[radix2 "#b"]
|
||||
[digit2 (:or "0" "1")]
|
||||
[num8 (:: prefix8 complex8)]
|
||||
[complex8 (:or real8
|
||||
(:: real8 "@" real8)
|
||||
(:: real8 "+" ureal8 "i")
|
||||
(:: real8 "-" ureal8 "i")
|
||||
(:: real8 "+i")
|
||||
(:: real8 "-i")
|
||||
(:: "+" ureal8 "i")
|
||||
(:: "-" ureal8 "i")
|
||||
(:: "+i")
|
||||
(:: "-i"))]
|
||||
[real8 (:: sign ureal8)]
|
||||
[ureal8 (:or uinteger8 (:: uinteger8 "/" uinteger8))]
|
||||
[uinteger8 (:: (:+ digit8) (:* #\#))]
|
||||
[prefix8 (:or (:: radix8 exactness)
|
||||
(:: exactness radix8))]
|
||||
[radix8 "#o"]
|
||||
[digit8 (:/ "0" "7")]
|
||||
|
||||
[num10 (:: prefix10 complex10)]
|
||||
[complex10 (:or real10
|
||||
(:: real10 "@" real10)
|
||||
(:: real10 "+" ureal10 "i")
|
||||
(:: real10 "-" ureal10 "i")
|
||||
(:: real10 "+i")
|
||||
(:: real10 "-i")
|
||||
(:: "+" ureal10 "i")
|
||||
(:: "-" ureal10 "i")
|
||||
(:: "+i")
|
||||
(:: "-i"))]
|
||||
[real10 (:: sign ureal10)]
|
||||
[ureal10 (:or uinteger10 (:: uinteger10 "/" uinteger10) decimal10)]
|
||||
[uinteger10 (:: (:+ digit10) (:* #\#))]
|
||||
[prefix10 (:or (:: radix10 exactness)
|
||||
(:: exactness radix10))]
|
||||
[radix10 (:? "#d")]
|
||||
[digit10 digit]
|
||||
[decimal10 (:or (:: uinteger10 suffix)
|
||||
(:: #\. (:+ digit10) (:* #\#) suffix)
|
||||
(:: (:+ digit10) #\. (:* digit10) (:* #\#) suffix)
|
||||
(:: (:+ digit10) (:+ #\#) #\. (:* #\#) suffix))]
|
||||
|
||||
[num16 (:: prefix16 complex16)]
|
||||
[complex16 (:or real16
|
||||
(:: real16 "@" real16)
|
||||
(:: real16 "+" ureal16 "i")
|
||||
(:: real16 "-" ureal16 "i")
|
||||
(:: real16 "+i")
|
||||
(:: real16 "-i")
|
||||
(:: "+" ureal16 "i")
|
||||
(:: "-" ureal16 "i")
|
||||
"+i"
|
||||
"-i")]
|
||||
[real16 (:: sign ureal16)]
|
||||
[ureal16 (:or uinteger16 (:: uinteger16 "/" uinteger16))]
|
||||
[uinteger16 (:: (:+ digit16) (:* #\#))]
|
||||
[prefix16 (:or (:: radix16 exactness)
|
||||
(:: exactness radix16))]
|
||||
[radix16 "#x"]
|
||||
[digit16 (:or digit (:/ #\a #\f) (:/ #\A #\F))]
|
||||
|
||||
|
||||
[suffix (:or "" (:: exponent-marker sign (:+ digit10)))]
|
||||
[exponent-marker (:or "e" "s" "f" "d" "l")]
|
||||
[sign (:or "" "+" "-")]
|
||||
[exactness (:or "" "#i" "#e")])
|
||||
|
||||
|
||||
(define stx-for-original-property (read-syntax #f (open-input-string "original")))
|
||||
|
||||
;; A macro to build the syntax object
|
||||
(define-syntax (build-so stx)
|
||||
(syntax-case stx ()
|
||||
((_ value start end)
|
||||
(with-syntax ((start-pos (datum->syntax-object
|
||||
(syntax end)
|
||||
(string->symbol
|
||||
(format "$~a-start-pos"
|
||||
(syntax-object->datum (syntax start))))))
|
||||
(end-pos (datum->syntax-object
|
||||
(syntax end)
|
||||
[real10 (:: sign ureal10)]
|
||||
[ureal10 (:or uinteger10 (:: uinteger10 "/" uinteger10) decimal10)]
|
||||
[uinteger10 (:: (:+ digit10) (:* #\#))]
|
||||
[prefix10 (:or (:: radix10 exactness)
|
||||
(:: exactness radix10))]
|
||||
[radix10 (:? "#d")]
|
||||
[digit10 digit]
|
||||
[decimal10 (:or (:: uinteger10 suffix)
|
||||
(:: #\. (:+ digit10) (:* #\#) suffix)
|
||||
(:: (:+ digit10) #\. (:* digit10) (:* #\#) suffix)
|
||||
(:: (:+ digit10) (:+ #\#) #\. (:* #\#) suffix))]
|
||||
|
||||
[num16 (:: prefix16 complex16)]
|
||||
[complex16 (:or real16
|
||||
(:: real16 "@" real16)
|
||||
(:: real16 "+" ureal16 "i")
|
||||
(:: real16 "-" ureal16 "i")
|
||||
(:: real16 "+i")
|
||||
(:: real16 "-i")
|
||||
(:: "+" ureal16 "i")
|
||||
(:: "-" ureal16 "i")
|
||||
"+i"
|
||||
"-i")]
|
||||
[real16 (:: sign ureal16)]
|
||||
[ureal16 (:or uinteger16 (:: uinteger16 "/" uinteger16))]
|
||||
[uinteger16 (:: (:+ digit16) (:* #\#))]
|
||||
[prefix16 (:or (:: radix16 exactness)
|
||||
(:: exactness radix16))]
|
||||
[radix16 "#x"]
|
||||
[digit16 (:or digit (:/ #\a #\f) (:/ #\A #\F))]
|
||||
|
||||
|
||||
[suffix (:or "" (:: exponent-marker sign (:+ digit10)))]
|
||||
[exponent-marker (:or "e" "s" "f" "d" "l")]
|
||||
[sign (:or "" "+" "-")]
|
||||
[exactness (:or "" "#i" "#e")])
|
||||
|
||||
|
||||
(define stx-for-original-property (read-syntax #f (open-input-string "original")))
|
||||
|
||||
;; A macro to build the syntax object
|
||||
(define-syntax (build-so stx)
|
||||
(syntax-case stx ()
|
||||
((_ value start end)
|
||||
(with-syntax ((start-pos (datum->syntax
|
||||
#'end
|
||||
(string->symbol
|
||||
(format "$~a-end-pos"
|
||||
(syntax-object->datum (syntax end))))))
|
||||
(source (datum->syntax-object
|
||||
(syntax end)
|
||||
'source-name)))
|
||||
(syntax
|
||||
(datum->syntax-object
|
||||
#f
|
||||
value
|
||||
(list source
|
||||
(position-line start-pos)
|
||||
(position-col start-pos)
|
||||
(position-offset start-pos)
|
||||
(- (position-offset end-pos)
|
||||
(position-offset start-pos)))
|
||||
stx-for-original-property))))))
|
||||
|
||||
(define (scheme-parser source-name)
|
||||
(parser
|
||||
(src-pos)
|
||||
|
||||
(start s)
|
||||
(end EOF)
|
||||
(error (lambda (a name val start end)
|
||||
(raise-read-error
|
||||
"read-error"
|
||||
source-name
|
||||
(position-line start)
|
||||
(position-col start)
|
||||
(position-offset start)
|
||||
(- (position-offset end)
|
||||
(position-offset start)))))
|
||||
(tokens data delim)
|
||||
|
||||
|
||||
(grammar
|
||||
|
||||
(s [(sexp-list) (reverse $1)])
|
||||
|
||||
(sexp [(DATUM) (build-so $1 1 1)]
|
||||
[(OP sexp-list CP) (build-so (reverse $2) 1 3)]
|
||||
[(HASHOP sexp-list CP) (build-so (list->vector (reverse $2)) 1 3)]
|
||||
[(QUOTE sexp) (build-so (list 'quote $2) 1 2)]
|
||||
[(QUASIQUOTE sexp) (build-so (list 'quasiquote $2) 1 2)]
|
||||
[(UNQUOTE sexp) (build-so (list 'unquote $2) 1 2)]
|
||||
[(UNQUOTE-SPLICING sexp) (build-so (list 'unquote-splicing $2) 1 2)]
|
||||
[(OP sexp-list DOT sexp CP) (build-so (append (reverse $2) $4) 1 5)])
|
||||
|
||||
(sexp-list [() null]
|
||||
[(sexp-list sexp) (cons $2 $1)]))))
|
||||
|
||||
(define (rs sn ip)
|
||||
(port-count-lines! ip)
|
||||
((scheme-parser sn) (lambda () (scheme-lexer ip))))
|
||||
|
||||
(define readsyntax
|
||||
(case-lambda ((sn) (rs sn (current-input-port)))
|
||||
((sn ip) (rs sn ip))))
|
||||
|
||||
(provide (rename readsyntax read-syntax))
|
||||
|
||||
)
|
||||
(format "$~a-start-pos"
|
||||
(syntax->datum #'start)))))
|
||||
(end-pos (datum->syntax
|
||||
#'end
|
||||
(string->symbol
|
||||
(format "$~a-end-pos"
|
||||
(syntax->datum #'end)))))
|
||||
(source (datum->syntax
|
||||
#'end
|
||||
'source-name)))
|
||||
(syntax
|
||||
(datum->syntax
|
||||
#f
|
||||
value
|
||||
(list source
|
||||
(position-line start-pos)
|
||||
(position-col start-pos)
|
||||
(position-offset start-pos)
|
||||
(- (position-offset end-pos)
|
||||
(position-offset start-pos)))
|
||||
stx-for-original-property))))))
|
||||
|
||||
(define (scheme-parser source-name)
|
||||
(parser
|
||||
(src-pos)
|
||||
|
||||
(start s)
|
||||
(end EOF)
|
||||
(error (lambda (a name val start end)
|
||||
(raise-read-error
|
||||
"read-error"
|
||||
source-name
|
||||
(position-line start)
|
||||
(position-col start)
|
||||
(position-offset start)
|
||||
(- (position-offset end)
|
||||
(position-offset start)))))
|
||||
(tokens data delim)
|
||||
|
||||
|
||||
(grammar
|
||||
|
||||
(s [(sexp-list) (reverse $1)])
|
||||
|
||||
(sexp [(DATUM) (build-so $1 1 1)]
|
||||
[(OP sexp-list CP) (build-so (reverse $2) 1 3)]
|
||||
[(HASHOP sexp-list CP) (build-so (list->vector (reverse $2)) 1 3)]
|
||||
[(QUOTE sexp) (build-so (list 'quote $2) 1 2)]
|
||||
[(QUASIQUOTE sexp) (build-so (list 'quasiquote $2) 1 2)]
|
||||
[(UNQUOTE sexp) (build-so (list 'unquote $2) 1 2)]
|
||||
[(UNQUOTE-SPLICING sexp) (build-so (list 'unquote-splicing $2) 1 2)]
|
||||
[(OP sexp-list DOT sexp CP) (build-so (append (reverse $2) $4) 1 5)])
|
||||
|
||||
(sexp-list [() null]
|
||||
[(sexp-list sexp) (cons $2 $1)]))))
|
||||
|
||||
(define (rs sn ip)
|
||||
(port-count-lines! ip)
|
||||
((scheme-parser sn) (lambda () (scheme-lexer ip))))
|
||||
|
||||
(define readsyntax
|
||||
(case-lambda ((sn) (rs sn (current-input-port)))
|
||||
((sn ip) (rs sn ip))))
|
||||
|
||||
(provide (rename-out [readsyntax read-syntax]))
|
||||
|
@ -1,24 +1,23 @@
|
||||
(module lex-plt-v200 mzscheme
|
||||
(require br-parser-tools/lex
|
||||
(prefix : br-parser-tools/lex-sre))
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base)
|
||||
br-parser-tools/lex
|
||||
(prefix-in : br-parser-tools/lex-sre))
|
||||
|
||||
(provide epsilon
|
||||
~
|
||||
(rename :* *)
|
||||
(rename :+ +)
|
||||
(rename :? ?)
|
||||
(rename :or :)
|
||||
(rename :& &)
|
||||
(rename :: @)
|
||||
(rename :~ ^)
|
||||
(rename :/ -))
|
||||
(provide epsilon ~
|
||||
(rename-out [:* *]
|
||||
[:+ +]
|
||||
[:? ?]
|
||||
[:or :]
|
||||
[:& &]
|
||||
[:: @]
|
||||
[:~ ^]
|
||||
[:/ -]))
|
||||
|
||||
(define-lex-trans epsilon
|
||||
(syntax-rules ()
|
||||
((_) "")))
|
||||
|
||||
(define-lex-trans ~
|
||||
(syntax-rules ()
|
||||
((_ re) (complement re)))))
|
||||
(define-lex-trans (epsilon stx)
|
||||
(syntax-case stx ()
|
||||
[(_) #'""]))
|
||||
|
||||
(define-lex-trans (~ stx)
|
||||
(syntax-case stx ()
|
||||
[(_ RE) #'(complement RE)]))
|
||||
|
||||
|
@ -1,119 +1,103 @@
|
||||
(module lex-sre mzscheme
|
||||
(require br-parser-tools/lex)
|
||||
|
||||
(provide (rename sre-* *)
|
||||
(rename sre-+ +)
|
||||
?
|
||||
(rename sre-= =)
|
||||
(rename sre->= >=)
|
||||
**
|
||||
(rename sre-or or)
|
||||
:
|
||||
seq
|
||||
&
|
||||
~
|
||||
(rename sre-- -)
|
||||
(rename sre-/ /)
|
||||
/-only-chars)
|
||||
|
||||
(define-lex-trans sre-*
|
||||
(syntax-rules ()
|
||||
((_ re ...)
|
||||
(repetition 0 +inf.0 (union re ...)))))
|
||||
|
||||
(define-lex-trans sre-+
|
||||
(syntax-rules ()
|
||||
((_ re ...)
|
||||
(repetition 1 +inf.0 (union re ...)))))
|
||||
|
||||
(define-lex-trans ?
|
||||
(syntax-rules ()
|
||||
((_ re ...)
|
||||
(repetition 0 1 (union re ...)))))
|
||||
|
||||
(define-lex-trans sre-=
|
||||
(syntax-rules ()
|
||||
((_ n re ...)
|
||||
(repetition n n (union re ...)))))
|
||||
|
||||
(define-lex-trans sre->=
|
||||
(syntax-rules ()
|
||||
((_ n re ...)
|
||||
(repetition n +inf.0 (union re ...)))))
|
||||
|
||||
(define-lex-trans **
|
||||
(syntax-rules ()
|
||||
((_ low #f re ...)
|
||||
(** low +inf.0 re ...))
|
||||
((_ low high re ...)
|
||||
(repetition low high (union re ...)))))
|
||||
|
||||
(define-lex-trans sre-or
|
||||
(syntax-rules ()
|
||||
((_ re ...)
|
||||
(union re ...))))
|
||||
|
||||
(define-lex-trans :
|
||||
(syntax-rules ()
|
||||
((_ re ...)
|
||||
(concatenation re ...))))
|
||||
|
||||
(define-lex-trans seq
|
||||
(syntax-rules ()
|
||||
((_ re ...)
|
||||
(concatenation re ...))))
|
||||
|
||||
(define-lex-trans &
|
||||
(syntax-rules ()
|
||||
((_ re ...)
|
||||
(intersection re ...))))
|
||||
|
||||
(define-lex-trans ~
|
||||
(syntax-rules ()
|
||||
((_ re ...)
|
||||
(char-complement (union re ...)))))
|
||||
|
||||
;; set difference
|
||||
(define-lex-trans (sre-- stx)
|
||||
(syntax-case stx ()
|
||||
((_)
|
||||
(raise-syntax-error #f
|
||||
"must have at least one argument"
|
||||
stx))
|
||||
((_ big-re re ...)
|
||||
(syntax (& big-re (complement (union re ...)))))))
|
||||
|
||||
(define-lex-trans (sre-/ stx)
|
||||
(syntax-case stx ()
|
||||
((_ range ...)
|
||||
(let ((chars
|
||||
(apply append (map (lambda (r)
|
||||
(let ((x (syntax-e r)))
|
||||
(cond
|
||||
((char? x) (list x))
|
||||
((string? x) (string->list x))
|
||||
(else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not a char or string"
|
||||
stx
|
||||
r)))))
|
||||
(syntax->list (syntax (range ...)))))))
|
||||
(unless (even? (length chars))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not given an even number of characters"
|
||||
stx))
|
||||
#`(/-only-chars #,@chars)))))
|
||||
|
||||
(define-lex-trans /-only-chars
|
||||
(syntax-rules ()
|
||||
((_ c1 c2)
|
||||
(char-range c1 c2))
|
||||
((_ c1 c2 c ...)
|
||||
(union (char-range c1 c2)
|
||||
(/-only-chars c ...)))))
|
||||
|
||||
)
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base)
|
||||
br-parser-tools/lex)
|
||||
|
||||
(provide (rename-out [sre-* *]
|
||||
[sre-+ +]
|
||||
[sre-= =]
|
||||
[sre->= >=]
|
||||
[sre-or or]
|
||||
[sre-- -]
|
||||
[sre-/ /])
|
||||
? ** : seq & ~ /-only-chars)
|
||||
|
||||
(define-lex-trans (sre-* stx)
|
||||
(syntax-case stx ()
|
||||
[(_ RE ...)
|
||||
#'(repetition 0 +inf.0 (union RE ...))]))
|
||||
|
||||
(define-lex-trans (sre-+ stx)
|
||||
(syntax-case stx ()
|
||||
[(_ RE ...)
|
||||
#'(repetition 1 +inf.0 (union RE ...))]))
|
||||
|
||||
(define-lex-trans (? stx)
|
||||
(syntax-case stx ()
|
||||
[(_ RE ...)
|
||||
#'(repetition 0 1 (union RE ...))]))
|
||||
|
||||
(define-lex-trans (sre-= stx)
|
||||
(syntax-case stx ()
|
||||
[(_ N RE ...)
|
||||
#'(repetition N N (union RE ...))]))
|
||||
|
||||
(define-lex-trans (sre->= stx)
|
||||
(syntax-case stx ()
|
||||
[(_ N RE ...)
|
||||
#'(repetition N +inf.0 (union RE ...))]))
|
||||
|
||||
(define-lex-trans (** stx)
|
||||
(syntax-case stx ()
|
||||
[(_ LOW #f RE ...)
|
||||
#'(** LOW +inf.0 RE ...)]
|
||||
[(_ LOW HIGH RE ...)
|
||||
#'(repetition LOW HIGH (union RE ...))]))
|
||||
|
||||
(define-lex-trans (sre-or stx)
|
||||
(syntax-case stx ()
|
||||
[(_ RE ...)
|
||||
#'(union RE ...)]))
|
||||
|
||||
(define-lex-trans (: stx)
|
||||
(syntax-case stx ()
|
||||
[(_ RE ...)
|
||||
#'(concatenation RE ...)]))
|
||||
|
||||
(define-lex-trans (seq stx)
|
||||
(syntax-case stx ()
|
||||
[(_ RE ...)
|
||||
#'(concatenation RE ...)]))
|
||||
|
||||
(define-lex-trans (& stx)
|
||||
(syntax-case stx ()
|
||||
[(_ RE ...)
|
||||
#'(intersection RE ...)]))
|
||||
|
||||
(define-lex-trans (~ stx)
|
||||
(syntax-case stx ()
|
||||
[(_ RE ...)
|
||||
#'(char-complement (union RE ...))]))
|
||||
|
||||
;; set difference
|
||||
(define-lex-trans (sre-- stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(raise-syntax-error #f
|
||||
"must have at least one argument"
|
||||
stx)]
|
||||
[(_ BIG-RE RE ...)
|
||||
#'(& BIG-RE (complement (union RE ...)))]))
|
||||
|
||||
(define-lex-trans (sre-/ stx)
|
||||
(syntax-case stx ()
|
||||
[(_ RANGE ...)
|
||||
(let ([chars
|
||||
(apply append (for/list ([r (in-list (syntax->list #'(RANGE ...)))])
|
||||
(let ([x (syntax-e r)])
|
||||
(cond
|
||||
[(char? x) (list x)]
|
||||
[(string? x) (string->list x)]
|
||||
[else
|
||||
(raise-syntax-error #f "not a char or string" stx r)]))))])
|
||||
(unless (even? (length chars))
|
||||
(raise-syntax-error #f "not given an even number of characters" stx))
|
||||
#`(/-only-chars #,@chars))]))
|
||||
|
||||
(define-lex-trans (/-only-chars stx)
|
||||
(syntax-case stx ()
|
||||
[(_ C1 C2)
|
||||
#'(char-range C1 C2)]
|
||||
[(_ C1 C2 C ...)
|
||||
#'(union (char-range C1 C2) (/-only-chars C ...))]))
|
||||
|
||||
|
||||
|
@ -1,9 +1,7 @@
|
||||
(module token-syntax mzscheme
|
||||
#lang racket/base
|
||||
(provide make-terminals-def terminals-def-t terminals-def?
|
||||
make-e-terminals-def e-terminals-def-t e-terminals-def?)
|
||||
|
||||
;; The things needed at compile time to handle definition of tokens
|
||||
|
||||
(provide make-terminals-def terminals-def-t terminals-def?
|
||||
make-e-terminals-def e-terminals-def-t e-terminals-def?)
|
||||
(define-struct terminals-def (t))
|
||||
(define-struct e-terminals-def (t))
|
||||
)
|
||||
;; The things needed at compile time to handle definition of tokens
|
||||
(define-struct terminals-def (t))
|
||||
(define-struct e-terminals-def (t))
|
||||
|
@ -1,92 +1,80 @@
|
||||
(module token mzscheme
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base "token-syntax.rkt"))
|
||||
|
||||
(require-for-syntax "token-syntax.rkt")
|
||||
;; Defining tokens
|
||||
|
||||
;; Defining tokens
|
||||
(provide define-tokens define-empty-tokens make-token token?
|
||||
(protect-out (rename-out [token-name real-token-name]))
|
||||
(protect-out (rename-out [token-value real-token-value]))
|
||||
(rename-out [token-name* token-name][token-value* token-value])
|
||||
(struct-out position)
|
||||
(struct-out position-token)
|
||||
(struct-out srcloc-token))
|
||||
|
||||
(provide define-tokens define-empty-tokens make-token token?
|
||||
(protect (rename token-name real-token-name))
|
||||
(protect (rename token-value real-token-value))
|
||||
(rename token-name* token-name)
|
||||
(rename token-value* token-value)
|
||||
(struct position (offset line col))
|
||||
(struct position-token (token start-pos end-pos))
|
||||
(struct srcloc-token (token srcloc)))
|
||||
|
||||
;; A token is either
|
||||
;; - symbol
|
||||
;; - (make-token symbol any)
|
||||
(define-struct token (name value) #:inspector (make-inspector))
|
||||
|
||||
;; A token is either
|
||||
;; - symbol
|
||||
;; - (make-token symbol any)
|
||||
(define-struct token (name value) (make-inspector))
|
||||
;; token-name*: token -> symbol
|
||||
(define (token-name* t)
|
||||
(cond
|
||||
[(symbol? t) t]
|
||||
[(token? t) (token-name t)]
|
||||
[else (raise-type-error 'token-name "symbol or struct:token" 0 t)]))
|
||||
|
||||
;; token-name*: token -> symbol
|
||||
(define (token-name* t)
|
||||
(cond
|
||||
((symbol? t) t)
|
||||
((token? t) (token-name t))
|
||||
(else (raise-type-error
|
||||
'token-name
|
||||
"symbol or struct:token"
|
||||
0
|
||||
t))))
|
||||
;; token-value*: token -> any
|
||||
(define (token-value* t)
|
||||
(cond
|
||||
[(symbol? t) #f]
|
||||
[(token? t) (token-value t)]
|
||||
[else (raise-type-error 'token-value "symbol or struct:token" 0 t)]))
|
||||
|
||||
;; token-value*: token -> any
|
||||
(define (token-value* t)
|
||||
(cond
|
||||
((symbol? t) #f)
|
||||
((token? t) (token-value t))
|
||||
(else (raise-type-error
|
||||
'token-value
|
||||
"symbol or struct:token"
|
||||
0
|
||||
t))))
|
||||
(define-for-syntax (make-ctor-name n)
|
||||
(datum->syntax n
|
||||
(string->symbol (format "token-~a" (syntax-e n)))
|
||||
n
|
||||
n))
|
||||
|
||||
(define-for-syntax (make-ctor-name n)
|
||||
(datum->syntax-object n
|
||||
(string->symbol (format "token-~a" (syntax-e n)))
|
||||
n
|
||||
n))
|
||||
(define-for-syntax ((make-define-tokens empty?) stx)
|
||||
(syntax-case stx ()
|
||||
[(_ NAME (TOKEN ...))
|
||||
(andmap identifier? (syntax->list #'(TOKEN ...)))
|
||||
(with-syntax (((marked-token ...)
|
||||
(map values #;(make-syntax-introducer)
|
||||
(syntax->list #'(TOKEN ...)))))
|
||||
(quasisyntax/loc stx
|
||||
(begin
|
||||
(define-syntax NAME
|
||||
#,(if empty?
|
||||
#'(make-e-terminals-def (quote-syntax (marked-token ...)))
|
||||
#'(make-terminals-def (quote-syntax (marked-token ...)))))
|
||||
#,@(map
|
||||
(λ (n)
|
||||
(when (eq? (syntax-e n) 'error)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"Cannot define a token named error."
|
||||
stx))
|
||||
(if empty?
|
||||
#`(define (#,(make-ctor-name n))
|
||||
'#,n)
|
||||
#`(define (#,(make-ctor-name n) x)
|
||||
(make-token '#,n x))))
|
||||
(syntax->list #'(TOKEN ...)))
|
||||
#;(define marked-token #f) #;...)))]
|
||||
[(_ ...)
|
||||
(raise-syntax-error #f
|
||||
"must have the form (define-tokens name (identifier ...)) or (define-empty-tokens name (identifier ...))"
|
||||
stx)]))
|
||||
|
||||
(define-for-syntax (make-define-tokens empty?)
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
((_ name (token ...))
|
||||
(andmap identifier? (syntax->list (syntax (token ...))))
|
||||
(with-syntax (((marked-token ...)
|
||||
(map values #;(make-syntax-introducer)
|
||||
(syntax->list (syntax (token ...))))))
|
||||
(quasisyntax/loc stx
|
||||
(begin
|
||||
(define-syntax name
|
||||
#,(if empty?
|
||||
#'(make-e-terminals-def (quote-syntax (marked-token ...)))
|
||||
#'(make-terminals-def (quote-syntax (marked-token ...)))))
|
||||
#,@(map
|
||||
(lambda (n)
|
||||
(when (eq? (syntax-e n) 'error)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"Cannot define a token named error."
|
||||
stx))
|
||||
(if empty?
|
||||
#`(define (#,(make-ctor-name n))
|
||||
'#,n)
|
||||
#`(define (#,(make-ctor-name n) x)
|
||||
(make-token '#,n x))))
|
||||
(syntax->list (syntax (token ...))))
|
||||
#;(define marked-token #f) #;...))))
|
||||
((_ ...)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"must have the form (define-tokens name (identifier ...)) or (define-empty-tokens name (identifier ...))"
|
||||
stx)))))
|
||||
(define-syntax define-tokens (make-define-tokens #f))
|
||||
(define-syntax define-empty-tokens (make-define-tokens #t))
|
||||
|
||||
(define-syntax define-tokens (make-define-tokens #f))
|
||||
(define-syntax define-empty-tokens (make-define-tokens #t))
|
||||
(define-struct position (offset line col) #:inspector #f)
|
||||
(define-struct position-token (token start-pos end-pos) #:inspector #f)
|
||||
|
||||
(define-struct position (offset line col) #f)
|
||||
(define-struct position-token (token start-pos end-pos) #f)
|
||||
(define-struct srcloc-token (token srcloc) #:inspector #f)
|
||||
|
||||
(define-struct srcloc-token (token srcloc) #f)
|
||||
)
|
||||
|
||||
|
@ -1,374 +1,297 @@
|
||||
(module input-file-parser mzscheme
|
||||
#lang racket/base
|
||||
(require "yacc-helper.rkt"
|
||||
"../private-lex/token-syntax.rkt"
|
||||
"grammar.rkt"
|
||||
racket/class
|
||||
racket/contract
|
||||
(for-template racket/base))
|
||||
|
||||
;; routines for parsing the input to the parser generator and producing a
|
||||
;; grammar (See grammar.rkt)
|
||||
|
||||
(require "yacc-helper.rkt"
|
||||
"../private-lex/token-syntax.rkt"
|
||||
"grammar.rkt"
|
||||
mzlib/class
|
||||
racket/contract)
|
||||
(require-for-template mzscheme)
|
||||
;; routines for parsing the input to the parser generator and producing a
|
||||
;; grammar (See grammar.rkt)
|
||||
|
||||
(define (is-a-grammar%? x) (is-a? x grammar%))
|
||||
(provide/contract
|
||||
(parse-input ((listof identifier?) (listof identifier?) (listof identifier?)
|
||||
(or/c #f syntax?) syntax? any/c . -> . is-a-grammar%?))
|
||||
(get-term-list ((listof identifier?) . -> . (listof identifier?))))
|
||||
|
||||
(define stx-for-original-property (read-syntax #f (open-input-string "original")))
|
||||
|
||||
;; get-args: ??? -> (values (listof syntax) (or/c #f (cons integer? stx)))
|
||||
(define (get-args i rhs src-pos term-defs)
|
||||
(let ((empty-table (make-hash-table))
|
||||
(biggest-pos #f))
|
||||
(hash-table-put! empty-table 'error #t)
|
||||
(for-each (lambda (td)
|
||||
(let ((v (syntax-local-value td)))
|
||||
(if (e-terminals-def? v)
|
||||
(for-each (lambda (s)
|
||||
(hash-table-put! empty-table (syntax-object->datum s) #t))
|
||||
(syntax->list (e-terminals-def-t v))))))
|
||||
term-defs)
|
||||
(let ([args
|
||||
(let get-args ((i i)
|
||||
(rhs rhs))
|
||||
(cond
|
||||
((null? rhs) null)
|
||||
(else
|
||||
(let ((b (car rhs))
|
||||
(name (if (hash-table-get empty-table (syntax-object->datum (car rhs)) (lambda () #f))
|
||||
(gensym)
|
||||
(string->symbol (format "$~a" i)))))
|
||||
(cond
|
||||
(src-pos
|
||||
(let ([start-pos-id
|
||||
(datum->syntax-object b (string->symbol (format "$~a-start-pos" i)) b stx-for-original-property)]
|
||||
[end-pos-id
|
||||
(datum->syntax-object b (string->symbol (format "$~a-end-pos" i)) b stx-for-original-property)])
|
||||
(set! biggest-pos (cons start-pos-id end-pos-id))
|
||||
`(,(datum->syntax-object b name b stx-for-original-property)
|
||||
,start-pos-id
|
||||
,end-pos-id
|
||||
,@(get-args (add1 i) (cdr rhs)))))
|
||||
(else
|
||||
`(,(datum->syntax-object b name b stx-for-original-property)
|
||||
,@(get-args (add1 i) (cdr rhs)))))))))])
|
||||
(values args biggest-pos))))
|
||||
|
||||
;; Given the list of terminal symbols and the precedence/associativity definitions,
|
||||
;; builds terminal structures (See grammar.rkt)
|
||||
;; build-terms: symbol list * symbol list list -> term list
|
||||
(define (build-terms term-list precs)
|
||||
(let ((counter 0)
|
||||
(provide/contract
|
||||
[parse-input ((listof identifier?) (listof identifier?) (listof identifier?)
|
||||
(or/c #f syntax?) syntax? any/c . -> . is-a-grammar%?)]
|
||||
[get-term-list ((listof identifier?) . -> . (listof identifier?))])
|
||||
|
||||
;;(term-list (cons (gensym) term-list))
|
||||
(define stx-for-original-property (read-syntax #f (open-input-string "original")))
|
||||
|
||||
;; Will map a terminal symbol to its precedence/associativity
|
||||
(prec-table (make-hash-table)))
|
||||
|
||||
;; Fill the prec table
|
||||
(for-each
|
||||
(lambda (p-decl)
|
||||
(begin0
|
||||
(let ((assoc (car p-decl)))
|
||||
(for-each
|
||||
(lambda (term-sym)
|
||||
(hash-table-put! prec-table term-sym (make-prec counter assoc)))
|
||||
(cdr p-decl)))
|
||||
(set! counter (add1 counter))))
|
||||
precs)
|
||||
|
||||
;; Build the terminal structures
|
||||
(map
|
||||
(lambda (term-sym)
|
||||
(make-term term-sym
|
||||
#f
|
||||
(hash-table-get prec-table term-sym (lambda () #f))))
|
||||
term-list)))
|
||||
|
||||
;; Retrieves the terminal symbols from a terminals-def (See terminal-syntax.rkt)
|
||||
;; get-terms-from-def: identifier? -> (listof identifier?)
|
||||
(define (get-terms-from-def term-syn)
|
||||
(let ((t (syntax-local-value term-syn (lambda () #f))))
|
||||
;; get-args: ??? -> (values (listof syntax) (or/c #f (cons integer? stx)))
|
||||
(define (get-args i rhs src-pos term-defs)
|
||||
(define empty-table (make-hasheq))
|
||||
(define biggest-pos #f)
|
||||
(hash-set! empty-table 'error #t)
|
||||
(for* ([td (in-list term-defs)]
|
||||
[v (in-value (syntax-local-value td))]
|
||||
#:when (e-terminals-def? v)
|
||||
[s (in-list (syntax->list (e-terminals-def-t v)))])
|
||||
(hash-set! empty-table (syntax->datum s) #t))
|
||||
(define args
|
||||
(let get-args ([i i][rhs rhs])
|
||||
(cond
|
||||
((terminals-def? t) (syntax->list (terminals-def-t t)))
|
||||
((e-terminals-def? t) (syntax->list (e-terminals-def-t t)))
|
||||
(else
|
||||
(raise-syntax-error
|
||||
'parser-tokens
|
||||
"undefined token group"
|
||||
term-syn)))))
|
||||
|
||||
(define (get-term-list term-group-names)
|
||||
(remove-duplicates
|
||||
(cons (datum->syntax-object #f 'error)
|
||||
(apply append
|
||||
(map get-terms-from-def term-group-names)))))
|
||||
[(null? rhs) null]
|
||||
[else
|
||||
(define b (car rhs))
|
||||
(define name (if (hash-ref empty-table (syntax->datum (car rhs)) #f)
|
||||
(gensym)
|
||||
(string->symbol (format "$~a" i))))
|
||||
(cond
|
||||
[src-pos
|
||||
(define start-pos-id
|
||||
(datum->syntax b (string->symbol (format "$~a-start-pos" i)) b stx-for-original-property))
|
||||
(define end-pos-id
|
||||
(datum->syntax b (string->symbol (format "$~a-end-pos" i)) b stx-for-original-property))
|
||||
(set! biggest-pos (cons start-pos-id end-pos-id))
|
||||
(list* (datum->syntax b name b stx-for-original-property)
|
||||
start-pos-id
|
||||
end-pos-id
|
||||
(get-args (add1 i) (cdr rhs)))]
|
||||
[else
|
||||
(list* (datum->syntax b name b stx-for-original-property)
|
||||
(get-args (add1 i) (cdr rhs)))])])))
|
||||
(values args biggest-pos))
|
||||
|
||||
(define (parse-input term-defs start ends prec-decls prods src-pos)
|
||||
(let* ((start-syms (map syntax-e start))
|
||||
;; Given the list of terminal symbols and the precedence/associativity definitions,
|
||||
;; builds terminal structures (See grammar.rkt)
|
||||
;; build-terms: symbol list * symbol list list -> term list
|
||||
(define (build-terms term-list precs)
|
||||
(define counter 0)
|
||||
;;(term-list (cons (gensym) term-list))
|
||||
;; Will map a terminal symbol to its precedence/associativity
|
||||
(define prec-table (make-hasheq))
|
||||
|
||||
(list-of-terms (map syntax-e (get-term-list term-defs)))
|
||||
;; Fill the prec table
|
||||
(for ([p-decl (in-list precs)])
|
||||
(define assoc (car p-decl))
|
||||
(for ([term-sym (in-list (cdr p-decl))])
|
||||
(hash-set! prec-table term-sym (make-prec counter assoc)))
|
||||
(set! counter (add1 counter)))
|
||||
|
||||
(end-terms
|
||||
(map
|
||||
(lambda (end)
|
||||
(unless (memq (syntax-e end) list-of-terms)
|
||||
(raise-syntax-error
|
||||
'parser-end-tokens
|
||||
(format "End token ~a not defined as a token"
|
||||
(syntax-e end))
|
||||
end))
|
||||
(syntax-e end))
|
||||
ends))
|
||||
;; Build the terminal structures
|
||||
(for/list ([term-sym (in-list term-list)])
|
||||
(make-term term-sym
|
||||
#f
|
||||
(hash-ref prec-table term-sym (λ () #f)))))
|
||||
|
||||
;; Get the list of terminals out of input-terms
|
||||
;; Retrieves the terminal symbols from a terminals-def (See terminal-syntax.rkt)
|
||||
;; get-terms-from-def: identifier? -> (listof identifier?)
|
||||
(define (get-terms-from-def term-syn)
|
||||
(define t (syntax-local-value term-syn #f))
|
||||
(cond
|
||||
[(terminals-def? t) (syntax->list (terminals-def-t t))]
|
||||
[(e-terminals-def? t) (syntax->list (e-terminals-def-t t))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
'parser-tokens
|
||||
"undefined token group"
|
||||
term-syn)]))
|
||||
|
||||
(list-of-non-terms
|
||||
(syntax-case prods ()
|
||||
(((non-term production ...) ...)
|
||||
(begin
|
||||
(for-each
|
||||
(lambda (nts)
|
||||
(if (memq (syntax-object->datum nts) list-of-terms)
|
||||
(raise-syntax-error
|
||||
'parser-non-terminals
|
||||
(format "~a used as both token and non-terminal"
|
||||
(syntax-object->datum nts))
|
||||
nts)))
|
||||
(syntax->list (syntax (non-term ...))))
|
||||
(define (get-term-list term-group-names)
|
||||
(remove-duplicates
|
||||
(cons (datum->syntax #f 'error)
|
||||
(apply append (map get-terms-from-def term-group-names)))))
|
||||
|
||||
(let ((dup (duplicate-list? (syntax-object->datum
|
||||
(syntax (non-term ...))))))
|
||||
(if dup
|
||||
(raise-syntax-error
|
||||
'parser-non-terminals
|
||||
(format "non-terminal ~a defined multiple times"
|
||||
dup)
|
||||
prods)))
|
||||
|
||||
(syntax-object->datum (syntax (non-term ...)))))
|
||||
(_
|
||||
(raise-syntax-error
|
||||
'parser-grammar
|
||||
"Grammar must be of the form (grammar (non-terminal productions ...) ...)"
|
||||
prods))))
|
||||
|
||||
;; Check the precedence declarations for errors and turn them into data
|
||||
(precs
|
||||
(syntax-case prec-decls ()
|
||||
(((type term ...) ...)
|
||||
(let ((p-terms
|
||||
(syntax-object->datum (syntax (term ... ...)))))
|
||||
(cond
|
||||
((duplicate-list? p-terms) =>
|
||||
(lambda (d)
|
||||
(define (parse-input term-defs start ends prec-decls prods src-pos)
|
||||
(define start-syms (map syntax-e start))
|
||||
(define list-of-terms (map syntax-e (get-term-list term-defs)))
|
||||
(define end-terms
|
||||
(for/list ([end (in-list ends)])
|
||||
(unless (memq (syntax-e end) list-of-terms)
|
||||
(raise-syntax-error
|
||||
'parser-end-tokens
|
||||
(format "End token ~a not defined as a token"
|
||||
(syntax-e end))
|
||||
end))
|
||||
(syntax-e end)))
|
||||
;; Get the list of terminals out of input-terms
|
||||
(define list-of-non-terms
|
||||
(syntax-case prods ()
|
||||
[((NON-TERM PRODUCTION ...) ...)
|
||||
(begin
|
||||
(for ([nts (in-list (syntax->list #'(NON-TERM ...)))]
|
||||
#:when (memq (syntax->datum nts) list-of-terms))
|
||||
(raise-syntax-error
|
||||
'parser-non-terminals
|
||||
(format "~a used as both token and non-terminal" (syntax->datum nts))
|
||||
nts))
|
||||
(let ([dup (duplicate-list? (syntax->datum #'(NON-TERM ...)))])
|
||||
(when dup
|
||||
(raise-syntax-error
|
||||
'parser-non-terminals
|
||||
(format "non-terminal ~a defined multiple times" dup)
|
||||
prods)))
|
||||
(syntax->datum #'(NON-TERM ...)))]
|
||||
[_ (raise-syntax-error
|
||||
'parser-grammar
|
||||
"Grammar must be of the form (grammar (non-terminal productions ...) ...)"
|
||||
prods)]))
|
||||
;; Check the precedence declarations for errors and turn them into data
|
||||
(define precs
|
||||
(syntax-case prec-decls ()
|
||||
[((TYPE TERM ...) ...)
|
||||
(let ([p-terms (syntax->datum #'(TERM ... ...))])
|
||||
(cond
|
||||
[(duplicate-list? p-terms) =>
|
||||
(λ (d)
|
||||
(raise-syntax-error
|
||||
'parser-precedences
|
||||
(format "duplicate precedence declaration for token ~a" d)
|
||||
prec-decls))]
|
||||
[else (for ([t (in-list (syntax->list #'(TERM ... ...)))]
|
||||
#:when (not (memq (syntax->datum t) list-of-terms)))
|
||||
(raise-syntax-error
|
||||
'parser-precedences
|
||||
(format "duplicate precedence declaration for token ~a"
|
||||
d)
|
||||
prec-decls)))
|
||||
(else
|
||||
(for-each
|
||||
(lambda (a)
|
||||
(for-each
|
||||
(lambda (t)
|
||||
(if (not (memq (syntax-object->datum t)
|
||||
list-of-terms))
|
||||
(raise-syntax-error
|
||||
'parser-precedences
|
||||
(format
|
||||
"Precedence declared for non-token ~a"
|
||||
(syntax-object->datum t))
|
||||
t)))
|
||||
(syntax->list a)))
|
||||
(syntax->list (syntax ((term ...) ...))))
|
||||
(for-each
|
||||
(lambda (type)
|
||||
(if (not (memq (syntax-object->datum type)
|
||||
`(left right nonassoc)))
|
||||
(raise-syntax-error
|
||||
'parser-precedences
|
||||
"Associativity must be left, right or nonassoc"
|
||||
type)))
|
||||
(syntax->list (syntax (type ...))))
|
||||
(syntax-object->datum prec-decls)))))
|
||||
(#f null)
|
||||
(_
|
||||
(raise-syntax-error
|
||||
'parser-precedences
|
||||
"Precedence declaration must be of the form (precs (assoc term ...) ...) where assoc is left, right or nonassoc"
|
||||
prec-decls))))
|
||||
|
||||
(terms (build-terms list-of-terms precs))
|
||||
(format "Precedence declared for non-token ~a" (syntax->datum t))
|
||||
t))
|
||||
(for ([type (in-list (syntax->list #'(TYPE ...)))]
|
||||
#:unless (memq (syntax->datum type) `(left right nonassoc)))
|
||||
(raise-syntax-error
|
||||
'parser-precedences
|
||||
"Associativity must be left, right or nonassoc"
|
||||
type))
|
||||
(syntax->datum prec-decls)]))]
|
||||
[#f null]
|
||||
[_ (raise-syntax-error
|
||||
'parser-precedences
|
||||
"Precedence declaration must be of the form (precs (assoc term ...) ...) where assoc is left, right or nonassoc"
|
||||
prec-decls)]))
|
||||
|
||||
(non-terms (map (lambda (non-term) (make-non-term non-term #f))
|
||||
list-of-non-terms))
|
||||
(term-table (make-hash-table))
|
||||
(non-term-table (make-hash-table)))
|
||||
(define terms (build-terms list-of-terms precs))
|
||||
(define non-terms (map (λ (non-term) (make-non-term non-term #f))
|
||||
list-of-non-terms))
|
||||
(define term-table (make-hasheq))
|
||||
(define non-term-table (make-hasheq))
|
||||
|
||||
(for-each (lambda (t)
|
||||
(hash-table-put! term-table (gram-sym-symbol t) t))
|
||||
terms)
|
||||
(for ([t (in-list terms)])
|
||||
(hash-set! term-table (gram-sym-symbol t) t))
|
||||
|
||||
(for-each (lambda (nt)
|
||||
(hash-table-put! non-term-table (gram-sym-symbol nt) nt))
|
||||
non-terms)
|
||||
(for ([nt (in-list non-terms)])
|
||||
(hash-set! non-term-table (gram-sym-symbol nt) nt))
|
||||
|
||||
(let* (
|
||||
;; parse-prod: syntax-object -> gram-sym vector
|
||||
(parse-prod
|
||||
(lambda (prod-so)
|
||||
(syntax-case prod-so ()
|
||||
((prod-rhs-sym ...)
|
||||
(andmap identifier? (syntax->list prod-so))
|
||||
(begin
|
||||
(for-each (lambda (t)
|
||||
(if (memq (syntax-object->datum t) end-terms)
|
||||
(raise-syntax-error
|
||||
'parser-production-rhs
|
||||
(format "~a is an end token and cannot be used in a production"
|
||||
(syntax-object->datum t))
|
||||
t)))
|
||||
(syntax->list prod-so))
|
||||
(list->vector
|
||||
(map (lambda (s)
|
||||
(hash-table-get
|
||||
term-table
|
||||
(syntax-object->datum s)
|
||||
(lambda ()
|
||||
(hash-table-get
|
||||
non-term-table
|
||||
(syntax-object->datum s)
|
||||
(lambda ()
|
||||
(raise-syntax-error
|
||||
'parser-production-rhs
|
||||
(format
|
||||
"~a is not declared as a terminal or non-terminal"
|
||||
(syntax-object->datum s))
|
||||
s))))))
|
||||
(syntax->list prod-so)))))
|
||||
(_
|
||||
(raise-syntax-error
|
||||
'parser-production-rhs
|
||||
"production right-hand-side must have form (symbol ...)"
|
||||
prod-so)))))
|
||||
;; parse-prod: syntax-object -> gram-sym vector
|
||||
(define (parse-prod prod-so)
|
||||
(syntax-case prod-so ()
|
||||
[(PROD-RHS-SYM ...)
|
||||
(andmap identifier? (syntax->list prod-so))
|
||||
(begin
|
||||
(for ([t (in-list (syntax->list prod-so))]
|
||||
#:when (memq (syntax->datum t) end-terms))
|
||||
(raise-syntax-error
|
||||
'parser-production-rhs
|
||||
(format "~a is an end token and cannot be used in a production" (syntax->datum t))
|
||||
t))
|
||||
(for/vector ([s (in-list (syntax->list prod-so))])
|
||||
(cond
|
||||
[(hash-ref term-table (syntax->datum s) #f)]
|
||||
[(hash-ref non-term-table (syntax->datum s) #f)]
|
||||
[else (raise-syntax-error
|
||||
'parser-production-rhs
|
||||
(format "~a is not declared as a terminal or non-terminal" (syntax->datum s))
|
||||
s)])))]
|
||||
[_ (raise-syntax-error
|
||||
'parser-production-rhs
|
||||
"production right-hand-side must have form (symbol ...)"
|
||||
prod-so)]))
|
||||
|
||||
;; parse-action: syntax-object * syntax-object -> syntax-object
|
||||
(parse-action
|
||||
(lambda (rhs act)
|
||||
(let-values ([(args biggest) (get-args 1 (syntax->list rhs) src-pos term-defs)])
|
||||
(let ([act
|
||||
(if biggest
|
||||
(with-syntax ([$n-start-pos (datum->syntax-object (car biggest) '$n-start-pos)]
|
||||
[$n-end-pos (datum->syntax-object (cdr biggest) '$n-end-pos)])
|
||||
#`(let ([$n-start-pos #,(car biggest)]
|
||||
[$n-end-pos #,(cdr biggest)])
|
||||
#,act))
|
||||
act)])
|
||||
(quasisyntax/loc act
|
||||
(lambda #,args
|
||||
#,act))))))
|
||||
;; parse-action: syntax-object * syntax-object -> syntax-object
|
||||
(define (parse-action rhs act-in)
|
||||
(define-values (args biggest) (get-args 1 (syntax->list rhs) src-pos term-defs))
|
||||
(define act
|
||||
(if biggest
|
||||
(with-syntax ([(CAR-BIGGEST . CDR-BIGGEST) biggest]
|
||||
[$N-START-POS (datum->syntax (car biggest) '$n-start-pos)]
|
||||
[$N-END-POS (datum->syntax (cdr biggest) '$n-end-pos)]
|
||||
[ACT-IN act-in])
|
||||
#'(let ([$N-START-POS CAR-BIGGEST]
|
||||
[$N-END-POS CDR-BIGGEST])
|
||||
ACT-IN))
|
||||
act-in))
|
||||
(with-syntax ([ARGS args][ACT act])
|
||||
(syntax/loc #'ACT (λ ARGS ACT))))
|
||||
|
||||
;; parse-prod+action: non-term * syntax-object -> production
|
||||
(parse-prod+action
|
||||
(lambda (nt prod-so)
|
||||
(syntax-case prod-so ()
|
||||
((prod-rhs action)
|
||||
(let ((p (parse-prod (syntax prod-rhs))))
|
||||
(make-prod
|
||||
nt
|
||||
p
|
||||
#f
|
||||
(let loop ((i (sub1 (vector-length p))))
|
||||
(if (>= i 0)
|
||||
(let ((gs (vector-ref p i)))
|
||||
(if (term? gs)
|
||||
(term-prec gs)
|
||||
(loop (sub1 i))))
|
||||
#f))
|
||||
(parse-action (syntax prod-rhs) (syntax action)))))
|
||||
((prod-rhs (prec term) action)
|
||||
(identifier? (syntax term))
|
||||
(let ((p (parse-prod (syntax prod-rhs))))
|
||||
(make-prod
|
||||
nt
|
||||
p
|
||||
#f
|
||||
(term-prec
|
||||
(hash-table-get
|
||||
term-table
|
||||
(syntax-object->datum (syntax term))
|
||||
(lambda ()
|
||||
(raise-syntax-error
|
||||
'parser-production-rhs
|
||||
(format
|
||||
"unrecognized terminal ~a in precedence declaration"
|
||||
(syntax-object->datum (syntax term)))
|
||||
(syntax term)))))
|
||||
(parse-action (syntax prod-rhs) (syntax action)))))
|
||||
(_
|
||||
(raise-syntax-error
|
||||
;; parse-prod+action: non-term * syntax-object -> production
|
||||
(define (parse-prod+action nt prod-so)
|
||||
(syntax-case prod-so ()
|
||||
[(PROD-RHS ACTION)
|
||||
(let ([p (parse-prod #'PROD-RHS)])
|
||||
(make-prod
|
||||
nt
|
||||
p
|
||||
#f
|
||||
(let loop ([i (sub1 (vector-length p))])
|
||||
(if (>= i 0)
|
||||
(let ([gs (vector-ref p i)])
|
||||
(if (term? gs)
|
||||
(term-prec gs)
|
||||
(loop (sub1 i))))
|
||||
#f))
|
||||
(parse-action #'PROD-RHS #'ACTION)))]
|
||||
[(PROD-RHS (PREC TERM) ACTION)
|
||||
(identifier? #'TERM)
|
||||
(let ([p (parse-prod #'PROD-RHS)])
|
||||
(make-prod
|
||||
nt
|
||||
p
|
||||
#f
|
||||
(term-prec
|
||||
(cond
|
||||
[(hash-ref term-table (syntax->datum #'TERM) #f)]
|
||||
[else (raise-syntax-error
|
||||
'parser-production-rhs
|
||||
"production must have form [(symbol ...) expression] or [(symbol ...) (prec symbol) expression]"
|
||||
prod-so)))))
|
||||
(format
|
||||
"unrecognized terminal ~a in precedence declaration"
|
||||
(syntax->datum #'TERM))
|
||||
#'TERM)]))
|
||||
(parse-action #'PROD-RHS #'ACTION)))]
|
||||
[_ (raise-syntax-error
|
||||
'parser-production-rhs
|
||||
"production must have form [(symbol ...) expression] or [(symbol ...) (prec symbol) expression]"
|
||||
prod-so)]))
|
||||
|
||||
;; parse-prod-for-nt: syntax-object -> production list
|
||||
(parse-prods-for-nt
|
||||
(lambda (prods-so)
|
||||
(syntax-case prods-so ()
|
||||
((nt productions ...)
|
||||
(> (length (syntax->list (syntax (productions ...)))) 0)
|
||||
(let ((nt (hash-table-get non-term-table
|
||||
(syntax-object->datum (syntax nt)))))
|
||||
(map (lambda (p) (parse-prod+action nt p))
|
||||
(syntax->list (syntax (productions ...))))))
|
||||
(_
|
||||
(raise-syntax-error
|
||||
'parser-productions
|
||||
"A production for a non-terminal must be (non-term right-hand-side ...) with at least 1 right hand side"
|
||||
prods-so))))))
|
||||
;; parse-prod-for-nt: syntax-object -> production list
|
||||
(define (parse-prods-for-nt prods-so)
|
||||
(syntax-case prods-so ()
|
||||
[(NT PRODUCTIONS ...)
|
||||
(positive? (length (syntax->list #'(PRODUCTIONS ...))))
|
||||
(let ([nt (hash-ref non-term-table (syntax->datum #'NT))])
|
||||
(map (λ (p) (parse-prod+action nt p)) (syntax->list #'(PRODUCTIONS ...))))]
|
||||
[_ (raise-syntax-error
|
||||
'parser-productions
|
||||
"A production for a non-terminal must be (non-term right-hand-side ...) with at least 1 right hand side"
|
||||
prods-so)]))
|
||||
|
||||
(for-each
|
||||
(lambda (sstx ssym)
|
||||
(unless (memq ssym list-of-non-terms)
|
||||
(raise-syntax-error
|
||||
'parser-start
|
||||
(format "Start symbol ~a not defined as a non-terminal" ssym)
|
||||
sstx)))
|
||||
start start-syms)
|
||||
(for ([sstx (in-list start)]
|
||||
[ssym (in-list start-syms)]
|
||||
#:unless (memq ssym list-of-non-terms))
|
||||
(raise-syntax-error
|
||||
'parser-start
|
||||
(format "Start symbol ~a not defined as a non-terminal" ssym)
|
||||
sstx))
|
||||
|
||||
(let* ((starts (map (lambda (x) (make-non-term (gensym) #f)) start-syms))
|
||||
(end-non-terms (map (lambda (x) (make-non-term (gensym) #f)) start-syms))
|
||||
(parsed-prods (map parse-prods-for-nt (syntax->list prods)))
|
||||
(start-prods
|
||||
(map (lambda (start end-non-term)
|
||||
(list (make-prod start (vector end-non-term) #f #f
|
||||
(syntax (lambda (x) x)))))
|
||||
starts end-non-terms))
|
||||
(prods
|
||||
`(,@start-prods
|
||||
,@(map
|
||||
(lambda (end-nt start-sym)
|
||||
(map
|
||||
(lambda (end)
|
||||
(make-prod end-nt
|
||||
(vector
|
||||
(hash-table-get non-term-table start-sym)
|
||||
(hash-table-get term-table end))
|
||||
#f
|
||||
#f
|
||||
(syntax (lambda (x) x))))
|
||||
end-terms))
|
||||
end-non-terms start-syms)
|
||||
,@parsed-prods)))
|
||||
(define starts (map (λ (x) (make-non-term (gensym) #f)) start-syms))
|
||||
(define end-non-terms (map (λ (x) (make-non-term (gensym) #f)) start-syms))
|
||||
(define parsed-prods (map parse-prods-for-nt (syntax->list prods)))
|
||||
(define start-prods (for/list ([start (in-list starts)]
|
||||
[end-non-term (in-list end-non-terms)])
|
||||
(list (make-prod start (vector end-non-term) #f #f #'values))))
|
||||
(define new-prods
|
||||
(append start-prods
|
||||
(for/list ([end-nt (in-list end-non-terms)]
|
||||
[start-sym (in-list start-syms)])
|
||||
(for/list ([end (in-list end-terms)])
|
||||
(make-prod end-nt
|
||||
(vector
|
||||
(hash-ref non-term-table start-sym)
|
||||
(hash-ref term-table end))
|
||||
#f
|
||||
#f
|
||||
#'values)))
|
||||
parsed-prods))
|
||||
|
||||
(make-object grammar%
|
||||
prods
|
||||
(map car start-prods)
|
||||
terms
|
||||
(append starts (append end-non-terms non-terms))
|
||||
(map (lambda (term-name)
|
||||
(hash-table-get term-table term-name))
|
||||
end-terms)))))))
|
||||
(make-object grammar%
|
||||
new-prods
|
||||
(map car start-prods)
|
||||
terms
|
||||
(append starts (append end-non-terms non-terms))
|
||||
(map (λ (term-name) (hash-ref term-table term-name)) end-terms)))
|
||||
|
@ -1,277 +1,252 @@
|
||||
(module lalr mzscheme
|
||||
|
||||
;; Compute LALR lookaheads from DeRemer and Pennello 1982
|
||||
|
||||
(require "lr0.rkt"
|
||||
"grammar.rkt"
|
||||
mzlib/list
|
||||
mzlib/class)
|
||||
|
||||
(provide compute-LA)
|
||||
|
||||
;; compute-DR: LR0-automaton * grammar -> (trans-key -> term set)
|
||||
;; computes for each state, non-term transition pair, the terminals
|
||||
;; which can transition out of the resulting state
|
||||
;; output term set is represented in bit-vector form
|
||||
(define (compute-DR a g)
|
||||
(lambda (tk)
|
||||
(let ((r (send a run-automaton (trans-key-st tk) (trans-key-gs tk))))
|
||||
(term-list->bit-vector
|
||||
(filter
|
||||
(lambda (term)
|
||||
(send a run-automaton r term))
|
||||
(send g get-terms))))))
|
||||
|
||||
;; compute-reads:
|
||||
;; LR0-automaton * grammar -> (trans-key -> trans-key list)
|
||||
(define (compute-reads a g)
|
||||
(let ((nullable-non-terms
|
||||
(filter (lambda (nt) (send g nullable-non-term? nt))
|
||||
(send g get-non-terms))))
|
||||
(lambda (tk)
|
||||
(let ((r (send a run-automaton (trans-key-st tk) (trans-key-gs tk))))
|
||||
(map (lambda (x) (make-trans-key r x))
|
||||
(filter (lambda (non-term) (send a run-automaton r non-term))
|
||||
nullable-non-terms))))))
|
||||
|
||||
;; compute-read: LR0-automaton * grammar -> (trans-key -> term set)
|
||||
;; output term set is represented in bit-vector form
|
||||
(define (compute-read a g)
|
||||
(let* ((dr (compute-DR a g))
|
||||
(reads (compute-reads a g)))
|
||||
(digraph-tk->terml (send a get-mapped-non-term-keys)
|
||||
reads
|
||||
dr
|
||||
(send a get-num-states))))
|
||||
;; returns the list of all k such that state k transitions to state start on the
|
||||
;; transitions in rhs (in order)
|
||||
(define (run-lr0-backward a rhs dot-pos start num-states)
|
||||
(let loop ((states (list start))
|
||||
(i (sub1 dot-pos)))
|
||||
(cond
|
||||
((< i 0) states)
|
||||
(else (loop (send a run-automaton-back states (vector-ref rhs i))
|
||||
(sub1 i))))))
|
||||
|
||||
;; prod->items-for-include: grammar * prod * non-term -> lr0-item list
|
||||
;; returns the list of all (B -> beta . nt gamma) such that prod = (B -> beta nt gamma)
|
||||
;; and gamma =>* epsilon
|
||||
(define (prod->items-for-include g prod nt)
|
||||
(let* ((rhs (prod-rhs prod))
|
||||
(rhs-l (vector-length rhs)))
|
||||
(append (if (and (> rhs-l 0) (eq? nt (vector-ref rhs (sub1 rhs-l))))
|
||||
(list (make-item prod (sub1 rhs-l)))
|
||||
null)
|
||||
(let loop ((i (sub1 rhs-l)))
|
||||
(cond
|
||||
((and (> i 0)
|
||||
(non-term? (vector-ref rhs i))
|
||||
(send g nullable-non-term? (vector-ref rhs i)))
|
||||
(if (eq? nt (vector-ref rhs (sub1 i)))
|
||||
(cons (make-item prod (sub1 i))
|
||||
(loop (sub1 i)))
|
||||
(loop (sub1 i))))
|
||||
(else null))))))
|
||||
|
||||
;; prod-list->items-for-include: grammar * prod list * non-term -> lr0-item list
|
||||
;; return the list of all (B -> beta . nt gamma) such that (B -> beta nt gamma) in prod-list
|
||||
;; and gamma =>* epsilon
|
||||
(define (prod-list->items-for-include g prod-list nt)
|
||||
(apply append (map (lambda (prod) (prod->items-for-include g prod nt)) prod-list)))
|
||||
|
||||
;; comput-includes: lr0-automaton * grammar -> (trans-key -> trans-key list)
|
||||
(define (compute-includes a g)
|
||||
(let ((num-states (send a get-num-states))
|
||||
(items-for-input-nt (make-vector (send g get-num-non-terms) null)))
|
||||
(for-each
|
||||
(lambda (input-nt)
|
||||
(vector-set! items-for-input-nt (non-term-index input-nt)
|
||||
(prod-list->items-for-include g (send g get-prods) input-nt)))
|
||||
(send g get-non-terms))
|
||||
(lambda (tk)
|
||||
(let* ((goal-state (trans-key-st tk))
|
||||
(non-term (trans-key-gs tk))
|
||||
(items (vector-ref items-for-input-nt (non-term-index non-term))))
|
||||
(trans-key-list-remove-dups
|
||||
(apply append
|
||||
(map (lambda (item)
|
||||
(let* ((prod (item-prod item))
|
||||
(rhs (prod-rhs prod))
|
||||
(lhs (prod-lhs prod)))
|
||||
(map (lambda (state)
|
||||
(make-trans-key state lhs))
|
||||
(run-lr0-backward a
|
||||
rhs
|
||||
(item-dot-pos item)
|
||||
goal-state
|
||||
num-states))))
|
||||
items)))))))
|
||||
|
||||
;; compute-lookback: lr0-automaton * grammar -> (kernel * proc -> trans-key list)
|
||||
(define (compute-lookback a g)
|
||||
(let ((num-states (send a get-num-states)))
|
||||
(lambda (state prod)
|
||||
(map (lambda (k) (make-trans-key k (prod-lhs prod)))
|
||||
(run-lr0-backward a (prod-rhs prod) (vector-length (prod-rhs prod)) state num-states)))))
|
||||
|
||||
;; compute-follow: LR0-automaton * grammar -> (trans-key -> term set)
|
||||
;; output term set is represented in bit-vector form
|
||||
(define (compute-follow a g includes)
|
||||
(let ((read (compute-read a g)))
|
||||
(digraph-tk->terml (send a get-mapped-non-term-keys)
|
||||
includes
|
||||
read
|
||||
(send a get-num-states))))
|
||||
|
||||
;; compute-LA: LR0-automaton * grammar -> kernel * prod -> term set
|
||||
;; output term set is represented in bit-vector form
|
||||
(define (compute-LA a g)
|
||||
(let* ((includes (compute-includes a g))
|
||||
(lookback (compute-lookback a g))
|
||||
(follow (compute-follow a g includes)))
|
||||
(lambda (k p)
|
||||
(let* ((l (lookback k p))
|
||||
(f (map follow l)))
|
||||
(apply bitwise-ior (cons 0 f))))))
|
||||
|
||||
(define (print-DR dr a g)
|
||||
(print-input-st-sym dr "DR" a g print-output-terms))
|
||||
(define (print-Read Read a g)
|
||||
(print-input-st-sym Read "Read" a g print-output-terms))
|
||||
(define (print-includes i a g)
|
||||
(print-input-st-sym i "includes" a g print-output-st-nt))
|
||||
(define (print-lookback l a g)
|
||||
(print-input-st-prod l "lookback" a g print-output-st-nt))
|
||||
(define (print-follow f a g)
|
||||
(print-input-st-sym f "follow" a g print-output-terms))
|
||||
(define (print-LA l a g)
|
||||
(print-input-st-prod l "LA" a g print-output-terms))
|
||||
|
||||
(define (print-input-st-sym f name a g print-output)
|
||||
(printf "~a:\n" name)
|
||||
(send a for-each-state
|
||||
(lambda (state)
|
||||
(for-each
|
||||
(lambda (non-term)
|
||||
(let ((res (f (make-trans-key state non-term))))
|
||||
(if (not (null? res))
|
||||
(printf "~a(~a, ~a) = ~a\n"
|
||||
name
|
||||
state
|
||||
(gram-sym-symbol non-term)
|
||||
(print-output res)))))
|
||||
(send g get-non-terms))))
|
||||
(newline))
|
||||
|
||||
(define (print-input-st-prod f name a g print-output)
|
||||
(printf "~a:\n" name)
|
||||
(send a for-each-state
|
||||
(lambda (state)
|
||||
(for-each
|
||||
(lambda (non-term)
|
||||
#lang racket/base
|
||||
(require "lr0.rkt"
|
||||
"grammar.rkt"
|
||||
racket/list
|
||||
racket/class)
|
||||
|
||||
;; Compute LALR lookaheads from DeRemer and Pennello 1982
|
||||
|
||||
(provide compute-LA)
|
||||
|
||||
;; compute-DR: LR0-automaton * grammar -> (trans-key -> term set)
|
||||
;; computes for each state, non-term transition pair, the terminals
|
||||
;; which can transition out of the resulting state
|
||||
;; output term set is represented in bit-vector form
|
||||
(define ((compute-DR a g) tk)
|
||||
(define r (send a run-automaton (trans-key-st tk) (trans-key-gs tk)))
|
||||
(term-list->bit-vector
|
||||
(filter (λ (term) (send a run-automaton r term)) (send g get-terms))))
|
||||
|
||||
;; compute-reads:
|
||||
;; LR0-automaton * grammar -> (trans-key -> trans-key list)
|
||||
(define (compute-reads a g)
|
||||
(define nullable-non-terms (filter (λ (nt) (send g nullable-non-term? nt)) (send g get-non-terms)))
|
||||
(λ (tk)
|
||||
(define r (send a run-automaton (trans-key-st tk) (trans-key-gs tk)))
|
||||
(for/list ([non-term (in-list nullable-non-terms)]
|
||||
#:when (send a run-automaton r non-term))
|
||||
(make-trans-key r non-term))))
|
||||
|
||||
;; compute-read: LR0-automaton * grammar -> (trans-key -> term set)
|
||||
;; output term set is represented in bit-vector form
|
||||
(define (compute-read a g)
|
||||
(define dr (compute-DR a g))
|
||||
(define reads (compute-reads a g))
|
||||
(digraph-tk->terml (send a get-mapped-non-term-keys)
|
||||
reads
|
||||
dr
|
||||
(send a get-num-states)))
|
||||
;; returns the list of all k such that state k transitions to state start on the
|
||||
;; transitions in rhs (in order)
|
||||
(define (run-lr0-backward a rhs dot-pos start num-states)
|
||||
(let loop ([states (list start)]
|
||||
[i (sub1 dot-pos)])
|
||||
(cond
|
||||
[(< i 0) states]
|
||||
[else (loop (send a run-automaton-back states (vector-ref rhs i))
|
||||
(sub1 i))])))
|
||||
|
||||
;; prod->items-for-include: grammar * prod * non-term -> lr0-item list
|
||||
;; returns the list of all (B -> beta . nt gamma) such that prod = (B -> beta nt gamma)
|
||||
;; and gamma =>* epsilon
|
||||
(define (prod->items-for-include g prod nt)
|
||||
(define rhs (prod-rhs prod))
|
||||
(define rhs-l (vector-length rhs))
|
||||
(append (if (and (> rhs-l 0) (eq? nt (vector-ref rhs (sub1 rhs-l))))
|
||||
(list (make-item prod (sub1 rhs-l)))
|
||||
null)
|
||||
(let loop ([i (sub1 rhs-l)])
|
||||
(cond
|
||||
[(and (> i 0)
|
||||
(non-term? (vector-ref rhs i))
|
||||
(send g nullable-non-term? (vector-ref rhs i)))
|
||||
(if (eq? nt (vector-ref rhs (sub1 i)))
|
||||
(cons (make-item prod (sub1 i))
|
||||
(loop (sub1 i)))
|
||||
(loop (sub1 i)))]
|
||||
[else null]))))
|
||||
|
||||
;; prod-list->items-for-include: grammar * prod list * non-term -> lr0-item list
|
||||
;; return the list of all (B -> beta . nt gamma) such that (B -> beta nt gamma) in prod-list
|
||||
;; and gamma =>* epsilon
|
||||
(define (prod-list->items-for-include g prod-list nt)
|
||||
(apply append (map (λ (prod) (prod->items-for-include g prod nt)) prod-list)))
|
||||
|
||||
;; comput-includes: lr0-automaton * grammar -> (trans-key -> trans-key list)
|
||||
(define (compute-includes a g)
|
||||
(define num-states (send a get-num-states))
|
||||
(define items-for-input-nt (make-vector (send g get-num-non-terms) null))
|
||||
(for ([input-nt (in-list (send g get-non-terms))])
|
||||
(vector-set! items-for-input-nt (non-term-index input-nt)
|
||||
(prod-list->items-for-include g (send g get-prods) input-nt)))
|
||||
(λ (tk)
|
||||
(define goal-state (trans-key-st tk))
|
||||
(define non-term (trans-key-gs tk))
|
||||
(define items (vector-ref items-for-input-nt (non-term-index non-term)))
|
||||
(trans-key-list-remove-dups
|
||||
(apply append
|
||||
(for/list ([item (in-list items)])
|
||||
(define prod (item-prod item))
|
||||
(define rhs (prod-rhs prod))
|
||||
(define lhs (prod-lhs prod))
|
||||
(map (λ (state) (make-trans-key state lhs))
|
||||
(run-lr0-backward a
|
||||
rhs
|
||||
(item-dot-pos item)
|
||||
goal-state
|
||||
num-states)))))))
|
||||
|
||||
;; compute-lookback: lr0-automaton * grammar -> (kernel * proc -> trans-key list)
|
||||
(define (compute-lookback a g)
|
||||
(define num-states (send a get-num-states))
|
||||
(λ (state prod)
|
||||
(map (λ (k) (make-trans-key k (prod-lhs prod)))
|
||||
(run-lr0-backward a (prod-rhs prod) (vector-length (prod-rhs prod)) state num-states))))
|
||||
|
||||
;; compute-follow: LR0-automaton * grammar -> (trans-key -> term set)
|
||||
;; output term set is represented in bit-vector form
|
||||
(define (compute-follow a g includes)
|
||||
(define read (compute-read a g))
|
||||
(digraph-tk->terml (send a get-mapped-non-term-keys)
|
||||
includes
|
||||
read
|
||||
(send a get-num-states)))
|
||||
|
||||
;; compute-LA: LR0-automaton * grammar -> kernel * prod -> term set
|
||||
;; output term set is represented in bit-vector form
|
||||
(define (compute-LA a g)
|
||||
(define includes (compute-includes a g))
|
||||
(define lookback (compute-lookback a g))
|
||||
(define follow (compute-follow a g includes))
|
||||
(λ (k p)
|
||||
(define l (lookback k p))
|
||||
(define f (map follow l))
|
||||
(apply bitwise-ior (cons 0 f))))
|
||||
|
||||
|
||||
(define (print-DR dr a g)
|
||||
(print-input-st-sym dr "DR" a g print-output-terms))
|
||||
(define (print-Read Read a g)
|
||||
(print-input-st-sym Read "Read" a g print-output-terms))
|
||||
(define (print-includes i a g)
|
||||
(print-input-st-sym i "includes" a g print-output-st-nt))
|
||||
(define (print-lookback l a g)
|
||||
(print-input-st-prod l "lookback" a g print-output-st-nt))
|
||||
(define (print-follow f a g)
|
||||
(print-input-st-sym f "follow" a g print-output-terms))
|
||||
(define (print-LA l a g)
|
||||
(print-input-st-prod l "LA" a g print-output-terms))
|
||||
|
||||
(define (print-input-st-sym f name a g print-output)
|
||||
(printf "~a:\n" name)
|
||||
(send a for-each-state
|
||||
(λ (state)
|
||||
(for-each
|
||||
(lambda (prod)
|
||||
(let ((res (f state prod)))
|
||||
(if (not (null? res))
|
||||
(printf "~a(~a, ~a) = ~a\n"
|
||||
name
|
||||
(kernel-index state)
|
||||
(prod-index prod)
|
||||
(print-output res)))))
|
||||
(send g get-prods-for-non-term non-term)))
|
||||
(send g get-non-terms)))))
|
||||
|
||||
(define (print-output-terms r)
|
||||
(map
|
||||
(lambda (p)
|
||||
(gram-sym-symbol p))
|
||||
r))
|
||||
|
||||
(define (print-output-st-nt r)
|
||||
(map
|
||||
(lambda (p)
|
||||
(list
|
||||
(kernel-index (trans-key-st p))
|
||||
(gram-sym-symbol (trans-key-gs p))))
|
||||
r))
|
||||
|
||||
;; init-tk-map : int -> (vectorof hashtable?)
|
||||
(define (init-tk-map n)
|
||||
(let ((v (make-vector n #f)))
|
||||
(let loop ((i (sub1 (vector-length v))))
|
||||
(when (>= i 0)
|
||||
(vector-set! v i (make-hash-table))
|
||||
(loop (sub1 i))))
|
||||
v))
|
||||
|
||||
;; lookup-tk-map : (vectorof (symbol? int hashtable)) -> trans-key? -> int
|
||||
(define (lookup-tk-map map)
|
||||
(lambda (tk)
|
||||
(let ((st (trans-key-st tk))
|
||||
(gs (trans-key-gs tk)))
|
||||
(hash-table-get (vector-ref map (kernel-index st))
|
||||
(gram-sym-symbol gs)
|
||||
(lambda () 0)))))
|
||||
|
||||
;; add-tk-map : (vectorof (symbol? int hashtable)) -> trans-key int ->
|
||||
(define (add-tk-map map)
|
||||
(lambda (tk v)
|
||||
(let ((st (trans-key-st tk))
|
||||
(gs (trans-key-gs tk)))
|
||||
(hash-table-put! (vector-ref map (kernel-index st))
|
||||
(gram-sym-symbol gs)
|
||||
v))))
|
||||
|
||||
;; digraph-tk->terml:
|
||||
;; (trans-key list) * (trans-key -> trans-key list) * (trans-key -> term list) * int * int * int
|
||||
;; -> (trans-key -> term list)
|
||||
;; DeRemer and Pennello 1982
|
||||
;; Computes (f x) = (f- x) union Union{(f y) | y in (edges x)}
|
||||
;; A specialization of digraph in the file graph.rkt
|
||||
(define (digraph-tk->terml nodes edges f- num-states)
|
||||
(letrec [
|
||||
;; Will map elements of trans-key to term sets represented as bit vectors
|
||||
(results (init-tk-map num-states))
|
||||
|
||||
;; Maps elements of trans-keys to integers.
|
||||
(N (init-tk-map num-states))
|
||||
|
||||
(get-N (lookup-tk-map N))
|
||||
(set-N (add-tk-map N))
|
||||
(get-f (lookup-tk-map results))
|
||||
(set-f (add-tk-map results))
|
||||
|
||||
(stack null)
|
||||
(push (lambda (x)
|
||||
(set! stack (cons x stack))))
|
||||
(pop (lambda ()
|
||||
(begin0
|
||||
(car stack)
|
||||
(set! stack (cdr stack)))))
|
||||
(depth (lambda () (length stack)))
|
||||
|
||||
;; traverse: 'a ->
|
||||
(traverse
|
||||
(lambda (x)
|
||||
(push x)
|
||||
(let ((d (depth)))
|
||||
(set-N x d)
|
||||
(set-f x (f- x))
|
||||
(for-each (lambda (y)
|
||||
(when (= 0 (get-N y))
|
||||
(traverse y))
|
||||
(set-f x (bitwise-ior (get-f x) (get-f y)))
|
||||
(set-N x (min (get-N x) (get-N y))))
|
||||
(edges x))
|
||||
(when (= d (get-N x))
|
||||
(let loop ((p (pop)))
|
||||
(set-N p +inf.0)
|
||||
(set-f p (get-f x))
|
||||
(unless (equal? x p)
|
||||
(loop (pop))))))))]
|
||||
(for-each (lambda (x)
|
||||
(when (= 0 (get-N x))
|
||||
(traverse x)))
|
||||
nodes)
|
||||
get-f))
|
||||
)
|
||||
(λ (non-term)
|
||||
(let ([res (f (make-trans-key state non-term))])
|
||||
(when (not (null? res))
|
||||
(printf "~a(~a, ~a) = ~a\n"
|
||||
name
|
||||
state
|
||||
(gram-sym-symbol non-term)
|
||||
(print-output res)))))
|
||||
(send g get-non-terms))))
|
||||
(newline))
|
||||
|
||||
(define (print-input-st-prod f name a g print-output)
|
||||
(printf "~a:\n" name)
|
||||
(send a for-each-state
|
||||
(λ (state)
|
||||
(for-each
|
||||
(λ (non-term)
|
||||
(for-each
|
||||
(λ (prod)
|
||||
(let ([res (f state prod)])
|
||||
(when (not (null? res))
|
||||
(printf "~a(~a, ~a) = ~a\n"
|
||||
name
|
||||
(kernel-index state)
|
||||
(prod-index prod)
|
||||
(print-output res)))))
|
||||
(send g get-prods-for-non-term non-term)))
|
||||
(send g get-non-terms)))))
|
||||
|
||||
(define (print-output-terms r)
|
||||
(map gram-sym-symbol r))
|
||||
|
||||
(define (print-output-st-nt r)
|
||||
(map (λ (p) (list (kernel-index (trans-key-st p)) (gram-sym-symbol (trans-key-gs p)))) r))
|
||||
|
||||
;; init-tk-map : int -> (vectorof hashtable?)
|
||||
(define (init-tk-map n)
|
||||
(define v (make-vector n #f))
|
||||
(let loop ([i (sub1 (vector-length v))])
|
||||
(when (>= i 0)
|
||||
(vector-set! v i (make-hasheq))
|
||||
(loop (sub1 i))))
|
||||
v)
|
||||
|
||||
;; lookup-tk-map : (vectorof (symbol? int hashtable)) -> trans-key? -> int
|
||||
(define ((lookup-tk-map map) tk)
|
||||
(define st (trans-key-st tk))
|
||||
(define gs (trans-key-gs tk))
|
||||
(hash-ref (vector-ref map (kernel-index st))
|
||||
(gram-sym-symbol gs)
|
||||
(λ () 0)))
|
||||
|
||||
;; add-tk-map : (vectorof (symbol? int hashtable)) -> trans-key int ->
|
||||
(define ((add-tk-map map) tk v)
|
||||
(define st (trans-key-st tk))
|
||||
(define gs (trans-key-gs tk))
|
||||
(hash-set! (vector-ref map (kernel-index st))
|
||||
(gram-sym-symbol gs)
|
||||
v))
|
||||
|
||||
;; digraph-tk->terml:
|
||||
;; (trans-key list) * (trans-key -> trans-key list) * (trans-key -> term list) * int * int * int
|
||||
;; -> (trans-key -> term list)
|
||||
;; DeRemer and Pennello 1982
|
||||
;; Computes (f x) = (f- x) union Union{(f y) | y in (edges x)}
|
||||
;; A specialization of digraph in the file graph.rkt
|
||||
(define (digraph-tk->terml nodes edges f- num-states)
|
||||
;; Will map elements of trans-key to term sets represented as bit vectors
|
||||
(define results (init-tk-map num-states))
|
||||
|
||||
;; Maps elements of trans-keys to integers.
|
||||
(define N (init-tk-map num-states))
|
||||
|
||||
(define get-N (lookup-tk-map N))
|
||||
(define set-N (add-tk-map N))
|
||||
(define get-f (lookup-tk-map results))
|
||||
(define set-f (add-tk-map results))
|
||||
|
||||
(define stack null)
|
||||
(define (push x) (set! stack (cons x stack)))
|
||||
(define (pop) (begin0
|
||||
(car stack)
|
||||
(set! stack (cdr stack))))
|
||||
(define (depth) (length stack))
|
||||
|
||||
;; traverse: 'a ->
|
||||
(define (traverse x)
|
||||
(push x)
|
||||
(let ([d (depth)])
|
||||
(set-N x d)
|
||||
(set-f x (f- x))
|
||||
(for-each (λ (y)
|
||||
(when (= 0 (get-N y))
|
||||
(traverse y))
|
||||
(set-f x (bitwise-ior (get-f x) (get-f y)))
|
||||
(set-N x (min (get-N x) (get-N y))))
|
||||
(edges x))
|
||||
(when (= d (get-N x))
|
||||
(let loop ([p (pop)])
|
||||
(set-N p +inf.0)
|
||||
(set-f p (get-f x))
|
||||
(unless (equal? x p)
|
||||
(loop (pop)))))))
|
||||
|
||||
(for ([x (in-list nodes)]
|
||||
#:when (zero? (get-N x)))
|
||||
(traverse x))
|
||||
get-f)
|
||||
|
@ -1,54 +1,54 @@
|
||||
(module parser-actions mzscheme
|
||||
(require "grammar.rkt")
|
||||
(provide (all-defined-except make-reduce make-reduce*)
|
||||
(rename make-reduce* make-reduce))
|
||||
|
||||
;; An action is
|
||||
;; - (make-shift int)
|
||||
;; - (make-reduce prod runtime-action)
|
||||
;; - (make-accept)
|
||||
;; - (make-goto int)
|
||||
;; - (no-action)
|
||||
;; A reduce contains a runtime-reduce so that sharing of the reduces can
|
||||
;; be easily transferred to sharing of runtime-reduces.
|
||||
|
||||
(define-struct action () (make-inspector))
|
||||
(define-struct (shift action) (state) (make-inspector))
|
||||
(define-struct (reduce action) (prod runtime-reduce) (make-inspector))
|
||||
(define-struct (accept action) () (make-inspector))
|
||||
(define-struct (goto action) (state) (make-inspector))
|
||||
(define-struct (no-action action) () (make-inspector))
|
||||
|
||||
(define (make-reduce* p)
|
||||
(make-reduce p
|
||||
(vector (prod-index p)
|
||||
(gram-sym-symbol (prod-lhs p))
|
||||
(vector-length (prod-rhs p)))))
|
||||
|
||||
;; A runtime-action is
|
||||
;; non-negative-int (shift)
|
||||
;; (vector int symbol int) (reduce)
|
||||
;; 'accept (accept)
|
||||
;; negative-int (goto)
|
||||
;; #f (no-action)
|
||||
|
||||
(define (action->runtime-action a)
|
||||
(cond
|
||||
((shift? a) (shift-state a))
|
||||
((reduce? a) (reduce-runtime-reduce a))
|
||||
((accept? a) 'accept)
|
||||
((goto? a) (- (+ (goto-state a) 1)))
|
||||
((no-action? a) #f)))
|
||||
|
||||
(define (runtime-shift? x) (and (integer? x) (>= x 0)))
|
||||
(define runtime-reduce? vector?)
|
||||
(define (runtime-accept? x) (eq? x 'accept))
|
||||
(define (runtime-goto? x) (and (integer? x) (< x 0)))
|
||||
|
||||
(define runtime-shift-state values)
|
||||
(define (runtime-reduce-prod-num x) (vector-ref x 0))
|
||||
(define (runtime-reduce-lhs x) (vector-ref x 1))
|
||||
(define (runtime-reduce-rhs-length x) (vector-ref x 2))
|
||||
(define (runtime-goto-state x) (- (+ x 1)))
|
||||
|
||||
)
|
||||
#lang racket/base
|
||||
(require "grammar.rkt")
|
||||
(provide (except-out (all-defined-out) make-reduce make-reduce*)
|
||||
(rename-out [make-reduce* make-reduce]))
|
||||
|
||||
;; An action is
|
||||
;; - (make-shift int)
|
||||
;; - (make-reduce prod runtime-action)
|
||||
;; - (make-accept)
|
||||
;; - (make-goto int)
|
||||
;; - (no-action)
|
||||
;; A reduce contains a runtime-reduce so that sharing of the reduces can
|
||||
;; be easily transferred to sharing of runtime-reduces.
|
||||
|
||||
(define-struct action () #:inspector (make-inspector))
|
||||
(define-struct (shift action) (state) #:inspector (make-inspector))
|
||||
(define-struct (reduce action) (prod runtime-reduce) #:inspector (make-inspector))
|
||||
(define-struct (accept action) () #:inspector (make-inspector))
|
||||
(define-struct (goto action) (state) #:inspector (make-inspector))
|
||||
(define-struct (no-action action) () #:inspector (make-inspector))
|
||||
|
||||
(define (make-reduce* p)
|
||||
(make-reduce p
|
||||
(vector (prod-index p)
|
||||
(gram-sym-symbol (prod-lhs p))
|
||||
(vector-length (prod-rhs p)))))
|
||||
|
||||
;; A runtime-action is
|
||||
;; non-negative-int (shift)
|
||||
;; (vector int symbol int) (reduce)
|
||||
;; 'accept (accept)
|
||||
;; negative-int (goto)
|
||||
;; #f (no-action)
|
||||
|
||||
(define (action->runtime-action a)
|
||||
(cond
|
||||
[(shift? a) (shift-state a)]
|
||||
[(reduce? a) (reduce-runtime-reduce a)]
|
||||
[(accept? a) 'accept]
|
||||
[(goto? a) (- (+ (goto-state a) 1))]
|
||||
[(no-action? a) #f]))
|
||||
|
||||
(define (runtime-shift? x) (and (integer? x) (>= x 0)))
|
||||
(define runtime-reduce? vector?)
|
||||
(define (runtime-accept? x) (eq? x 'accept))
|
||||
(define (runtime-goto? x) (and (integer? x) (< x 0)))
|
||||
|
||||
(define runtime-shift-state values)
|
||||
(define (runtime-reduce-prod-num x) (vector-ref x 0))
|
||||
(define (runtime-reduce-lhs x) (vector-ref x 1))
|
||||
(define (runtime-reduce-rhs-length x) (vector-ref x 2))
|
||||
(define (runtime-goto-state x) (- (+ x 1)))
|
||||
|
||||
|
||||
|
@ -1,290 +1,264 @@
|
||||
#lang scheme/base
|
||||
#lang racket/base
|
||||
(require "grammar.rkt"
|
||||
"lr0.rkt"
|
||||
"lalr.rkt"
|
||||
"parser-actions.rkt"
|
||||
racket/contract
|
||||
racket/list
|
||||
racket/class)
|
||||
|
||||
;; Routine to build the LALR table
|
||||
;; Routine to build the LALR table
|
||||
|
||||
(require "grammar.rkt"
|
||||
"lr0.rkt"
|
||||
"lalr.rkt"
|
||||
"parser-actions.rkt"
|
||||
racket/contract
|
||||
mzlib/list
|
||||
mzlib/class)
|
||||
|
||||
(define (is-a-grammar%? x) (is-a? x grammar%))
|
||||
(provide/contract
|
||||
(build-table (-> is-a-grammar%? string? any/c
|
||||
(vectorof (listof (cons/c (or/c term? non-term?) action?))))))
|
||||
(define (is-a-grammar%? x) (is-a? x grammar%))
|
||||
(provide/contract
|
||||
(build-table (-> is-a-grammar%? string? any/c
|
||||
(vectorof (listof (cons/c (or/c term? non-term?) action?))))))
|
||||
|
||||
;; A parse-table is (vectorof (listof (cons/c gram-sym? action)))
|
||||
;; A grouped-parse-table is (vectorof (listof (cons/c gram-sym? (listof action))))
|
||||
;; A parse-table is (vectorof (listof (cons/c gram-sym? action)))
|
||||
;; A grouped-parse-table is (vectorof (listof (cons/c gram-sym? (listof action))))
|
||||
|
||||
;; make-parse-table : int -> parse-table
|
||||
(define (make-parse-table num-states)
|
||||
(make-vector num-states null))
|
||||
;; make-parse-table : int -> parse-table
|
||||
(define (make-parse-table num-states)
|
||||
(make-vector num-states null))
|
||||
|
||||
;; table-add!: parse-table nat symbol action ->
|
||||
(define (table-add! table state-index symbol val)
|
||||
(vector-set! table state-index (cons (cons symbol val)
|
||||
(vector-ref table state-index))))
|
||||
;; table-add!: parse-table nat symbol action ->
|
||||
(define (table-add! table state-index symbol val)
|
||||
(vector-set! table state-index (cons (cons symbol val)
|
||||
(vector-ref table state-index))))
|
||||
|
||||
;; group-table : parse-table -> grouped-parse-table
|
||||
(define (group-table table)
|
||||
(list->vector
|
||||
(map
|
||||
(lambda (state-entry)
|
||||
(let ((ht (make-hash)))
|
||||
(for-each
|
||||
(lambda (gs/actions)
|
||||
(let ((group (hash-ref ht (car gs/actions) (lambda () null))))
|
||||
(unless (member (cdr gs/actions) group)
|
||||
(hash-set! ht (car gs/actions) (cons (cdr gs/actions) group)))))
|
||||
state-entry)
|
||||
(hash-map ht cons)))
|
||||
(vector->list table))))
|
||||
;; group-table : parse-table -> grouped-parse-table
|
||||
(define (group-table table)
|
||||
(list->vector
|
||||
(for/list ([state-entry (in-list (vector->list table))])
|
||||
(define ht (make-hasheq))
|
||||
(for* ([gs/actions (in-list state-entry)]
|
||||
[group (in-value (hash-ref ht (car gs/actions) (λ () null)))]
|
||||
#:unless (member (cdr gs/actions) group))
|
||||
(hash-set! ht (car gs/actions) (cons (cdr gs/actions) group)))
|
||||
(hash-map ht cons))))
|
||||
|
||||
;; table-map : (vectorof (listof (cons/c gram-sym? X))) (gram-sym? X -> Y) ->
|
||||
;; (vectorof (listof (cons/c gram-sym? Y)))
|
||||
(define (table-map f table)
|
||||
(list->vector
|
||||
(map
|
||||
(lambda (state-entry)
|
||||
(map
|
||||
(lambda (gs/X)
|
||||
(cons (car gs/X) (f (car gs/X) (cdr gs/X))))
|
||||
state-entry))
|
||||
(vector->list table))))
|
||||
;; table-map : (vectorof (listof (cons/c gram-sym? X))) (gram-sym? X -> Y) ->
|
||||
;; (vectorof (listof (cons/c gram-sym? Y)))
|
||||
(define (table-map f table)
|
||||
(list->vector
|
||||
(for/list ([state-entry (in-list (vector->list table))])
|
||||
(for/list ([gs/X (in-list state-entry)])
|
||||
(cons (car gs/X) (f (car gs/X) (cdr gs/X)))))))
|
||||
|
||||
(define (bit-vector-for-each f bv)
|
||||
(let loop ([bv bv] [number 0])
|
||||
(cond
|
||||
[(zero? bv) (void)]
|
||||
[(= 1 (bitwise-and 1 bv))
|
||||
(f number)
|
||||
(loop (arithmetic-shift bv -1) (add1 number))]
|
||||
[else (loop (arithmetic-shift bv -1) (add1 number))])))
|
||||
|
||||
(define (bit-vector-for-each f bv)
|
||||
(letrec ((for-each
|
||||
(lambda (bv number)
|
||||
(cond
|
||||
((= 0 bv) (void))
|
||||
((= 1 (bitwise-and 1 bv))
|
||||
(f number)
|
||||
(for-each (arithmetic-shift bv -1) (add1 number)))
|
||||
(else (for-each (arithmetic-shift bv -1) (add1 number)))))))
|
||||
(for-each bv 0)))
|
||||
|
||||
;; print-entry: symbol action output-port ->
|
||||
;; prints the action a for lookahead sym to the given port
|
||||
(define (print-entry sym a port)
|
||||
(define s "\t~a\t\t\t\t\t~a\t~a\n")
|
||||
(cond
|
||||
[(shift? a) (fprintf port s sym "shift" (shift-state a))]
|
||||
[(reduce? a) (fprintf port s sym "reduce" (prod-index (reduce-prod a)))]
|
||||
[(accept? a) (fprintf port s sym "accept" "")]
|
||||
[(goto? a) (fprintf port s sym "goto" (goto-state a))]))
|
||||
|
||||
;; print-entry: symbol action output-port ->
|
||||
;; prints the action a for lookahead sym to the given port
|
||||
(define (print-entry sym a port)
|
||||
(let ((s "\t~a\t\t\t\t\t~a\t~a\n"))
|
||||
(cond
|
||||
((shift? a)
|
||||
(fprintf port s sym "shift" (shift-state a)))
|
||||
((reduce? a)
|
||||
(fprintf port s sym "reduce" (prod-index (reduce-prod a))))
|
||||
((accept? a)
|
||||
(fprintf port s sym "accept" ""))
|
||||
((goto? a)
|
||||
(fprintf port s sym "goto" (goto-state a))))))
|
||||
|
||||
;; count: ('a -> bool) * 'a list -> num
|
||||
;; counts the number of elements in list that satisfy pred
|
||||
(define (count pred list)
|
||||
(cond
|
||||
[(null? list) 0]
|
||||
[(pred (car list)) (+ 1 (count pred (cdr list)))]
|
||||
[else (count pred (cdr list))]))
|
||||
|
||||
;; count: ('a -> bool) * 'a list -> num
|
||||
;; counts the number of elements in list that satisfy pred
|
||||
(define (count pred list)
|
||||
(cond
|
||||
((null? list) 0)
|
||||
((pred (car list)) (+ 1 (count pred (cdr list))))
|
||||
(else (count pred (cdr list)))))
|
||||
;; display-parser: LR0-automaton grouped-parse-table (listof prod?) output-port ->
|
||||
;; Prints out the parser given by table.
|
||||
(define (display-parser a grouped-table prods port)
|
||||
(define SR-conflicts 0)
|
||||
(define RR-conflicts 0)
|
||||
(for ([prod (in-list prods)])
|
||||
(fprintf port
|
||||
"~a\t~a\t=\t~a\n"
|
||||
(prod-index prod)
|
||||
(gram-sym-symbol (prod-lhs prod))
|
||||
(map gram-sym-symbol (vector->list (prod-rhs prod)))))
|
||||
|
||||
;; display-parser: LR0-automaton grouped-parse-table (listof prod?) output-port ->
|
||||
;; Prints out the parser given by table.
|
||||
(define (display-parser a grouped-table prods port)
|
||||
(let* ((SR-conflicts 0)
|
||||
(RR-conflicts 0))
|
||||
(for-each
|
||||
(lambda (prod)
|
||||
(fprintf port
|
||||
"~a\t~a\t=\t~a\n"
|
||||
(prod-index prod)
|
||||
(gram-sym-symbol (prod-lhs prod))
|
||||
(map gram-sym-symbol (vector->list (prod-rhs prod)))))
|
||||
prods)
|
||||
(send a for-each-state
|
||||
(lambda (state)
|
||||
(send a for-each-state
|
||||
(λ (state)
|
||||
(fprintf port "State ~a\n" (kernel-index state))
|
||||
(for-each (lambda (item)
|
||||
(fprintf port "\t~a\n" (item->string item)))
|
||||
(kernel-items state))
|
||||
(for ([item (in-list (kernel-items state))])
|
||||
(fprintf port "\t~a\n" (item->string item)))
|
||||
(newline port)
|
||||
(for-each
|
||||
(lambda (gs/action)
|
||||
(let ((sym (gram-sym-symbol (car gs/action)))
|
||||
(act (cdr gs/action)))
|
||||
(cond
|
||||
((null? act) (void))
|
||||
((null? (cdr act))
|
||||
(print-entry sym (car act) port))
|
||||
(else
|
||||
(fprintf port "begin conflict:\n")
|
||||
(when (> (count reduce? act) 1)
|
||||
(set! RR-conflicts (add1 RR-conflicts)))
|
||||
(when (> (count shift? act) 0)
|
||||
(set! SR-conflicts (add1 SR-conflicts)))
|
||||
(map (lambda (x) (print-entry sym x port)) act)
|
||||
(fprintf port "end conflict\n")))))
|
||||
(vector-ref grouped-table (kernel-index state)))
|
||||
(for ([gs/action (in-list (vector-ref grouped-table (kernel-index state)))])
|
||||
(define sym (gram-sym-symbol (car gs/action)))
|
||||
(define act (cdr gs/action))
|
||||
(cond
|
||||
[(null? act) (void)]
|
||||
[(null? (cdr act))
|
||||
(print-entry sym (car act) port)]
|
||||
[else
|
||||
(fprintf port "begin conflict:\n")
|
||||
(when (> (count reduce? act) 1)
|
||||
(set! RR-conflicts (add1 RR-conflicts)))
|
||||
(when (> (count shift? act) 0)
|
||||
(set! SR-conflicts (add1 SR-conflicts)))
|
||||
(map (λ (x) (print-entry sym x port)) act)
|
||||
(fprintf port "end conflict\n")]))
|
||||
(newline port)))
|
||||
|
||||
(when (> SR-conflicts 0)
|
||||
(fprintf port "~a shift/reduce conflict~a\n"
|
||||
SR-conflicts
|
||||
(if (= SR-conflicts 1) "" "s")))
|
||||
(when (> RR-conflicts 0)
|
||||
(fprintf port "~a reduce/reduce conflict~a\n"
|
||||
RR-conflicts
|
||||
(if (= RR-conflicts 1) "" "s")))))
|
||||
|
||||
;; resolve-conflict : (listof action?) -> action? bool bool
|
||||
(define (resolve-conflict actions)
|
||||
(cond
|
||||
((null? actions) (values (make-no-action) #f #f))
|
||||
((null? (cdr actions))
|
||||
(values (car actions) #f #f))
|
||||
(else
|
||||
(let ((SR-conflict? (> (count shift? actions) 0))
|
||||
(RR-conflict? (> (count reduce? actions) 1)))
|
||||
(let loop ((current-guess #f)
|
||||
(rest actions))
|
||||
(cond
|
||||
((null? rest) (values current-guess SR-conflict? RR-conflict?))
|
||||
((shift? (car rest)) (values (car rest) SR-conflict? RR-conflict?))
|
||||
((not current-guess)
|
||||
(loop (car rest) (cdr rest)))
|
||||
((and (reduce? (car rest))
|
||||
(< (prod-index (reduce-prod (car rest)))
|
||||
(prod-index (reduce-prod current-guess))))
|
||||
(loop (car rest) (cdr rest)))
|
||||
((accept? (car rest))
|
||||
(eprintf "accept/reduce or accept/shift conflicts. Check the grammar for useless cycles of productions\n")
|
||||
(loop current-guess (cdr rest)))
|
||||
(else (loop current-guess (cdr rest)))))))))
|
||||
(when (> SR-conflicts 0)
|
||||
(fprintf port "~a shift/reduce conflict~a\n"
|
||||
SR-conflicts
|
||||
(if (= SR-conflicts 1) "" "s")))
|
||||
(when (> RR-conflicts 0)
|
||||
(fprintf port "~a reduce/reduce conflict~a\n"
|
||||
RR-conflicts
|
||||
(if (= RR-conflicts 1) "" "s"))))
|
||||
|
||||
;; resolve-conflicts : grouped-parse-table bool -> parse-table
|
||||
(define (resolve-conflicts grouped-table suppress)
|
||||
(let* ((SR-conflicts 0)
|
||||
(RR-conflicts 0)
|
||||
(table (table-map
|
||||
(lambda (gs actions)
|
||||
(let-values (((action SR? RR?)
|
||||
(resolve-conflict actions)))
|
||||
(when SR?
|
||||
(set! SR-conflicts (add1 SR-conflicts)))
|
||||
(when RR?
|
||||
(set! RR-conflicts (add1 RR-conflicts)))
|
||||
action))
|
||||
grouped-table)))
|
||||
(unless suppress
|
||||
(when (> SR-conflicts 0)
|
||||
(eprintf "~a shift/reduce conflict~a\n"
|
||||
SR-conflicts
|
||||
(if (= SR-conflicts 1) "" "s")))
|
||||
(when (> RR-conflicts 0)
|
||||
(eprintf "~a reduce/reduce conflict~a\n"
|
||||
RR-conflicts
|
||||
(if (= RR-conflicts 1) "" "s"))))
|
||||
table))
|
||||
;; resolve-conflict : (listof action?) -> action? bool bool
|
||||
(define (resolve-conflict actions)
|
||||
(cond
|
||||
[(null? actions) (values (make-no-action) #f #f)]
|
||||
[(null? (cdr actions)) (values (car actions) #f #f)]
|
||||
[else
|
||||
(define SR-conflict? (> (count shift? actions) 0))
|
||||
(define RR-conflict? (> (count reduce? actions) 1))
|
||||
(let loop ((current-guess #f)
|
||||
(rest actions))
|
||||
(cond
|
||||
[(null? rest) (values current-guess SR-conflict? RR-conflict?)]
|
||||
[(shift? (car rest)) (values (car rest) SR-conflict? RR-conflict?)]
|
||||
[(not current-guess) (loop (car rest) (cdr rest))]
|
||||
[(and (reduce? (car rest))
|
||||
(< (prod-index (reduce-prod (car rest)))
|
||||
(prod-index (reduce-prod current-guess))))
|
||||
(loop (car rest) (cdr rest))]
|
||||
[(accept? (car rest))
|
||||
(eprintf "accept/reduce or accept/shift conflicts. Check the grammar for useless cycles of productions\n")
|
||||
(loop current-guess (cdr rest))]
|
||||
[else (loop current-guess (cdr rest))]))]))
|
||||
|
||||
;; resolve-conflicts : grouped-parse-table bool -> parse-table
|
||||
(define (resolve-conflicts grouped-table suppress)
|
||||
(define SR-conflicts 0)
|
||||
(define RR-conflicts 0)
|
||||
(define table (table-map
|
||||
(λ (gs actions)
|
||||
(let-values ([(action SR? RR?)
|
||||
(resolve-conflict actions)])
|
||||
(when SR?
|
||||
(set! SR-conflicts (add1 SR-conflicts)))
|
||||
(when RR?
|
||||
(set! RR-conflicts (add1 RR-conflicts)))
|
||||
action))
|
||||
grouped-table))
|
||||
(unless suppress
|
||||
(when (> SR-conflicts 0)
|
||||
(eprintf "~a shift/reduce conflict~a\n"
|
||||
SR-conflicts
|
||||
(if (= SR-conflicts 1) "" "s")))
|
||||
(when (> RR-conflicts 0)
|
||||
(eprintf "~a reduce/reduce conflict~a\n"
|
||||
RR-conflicts
|
||||
(if (= RR-conflicts 1) "" "s"))))
|
||||
table)
|
||||
|
||||
;; resolve-sr-conflict : (listof action) (union int #f) -> (listof action)
|
||||
;; Resolves a single shift-reduce conflict, if precedences are in place.
|
||||
(define (resolve-sr-conflict/prec actions shift-prec)
|
||||
(let* ((shift (if (shift? (car actions))
|
||||
(car actions)
|
||||
(cadr actions)))
|
||||
(reduce (if (shift? (car actions))
|
||||
(cadr actions)
|
||||
(car actions)))
|
||||
(reduce-prec (prod-prec (reduce-prod reduce))))
|
||||
(cond
|
||||
((and shift-prec reduce-prec)
|
||||
(cond
|
||||
((< (prec-num shift-prec) (prec-num reduce-prec))
|
||||
(list reduce))
|
||||
((> (prec-num shift-prec) (prec-num reduce-prec))
|
||||
(list shift))
|
||||
((eq? 'left (prec-assoc shift-prec))
|
||||
(list reduce))
|
||||
((eq? 'right (prec-assoc shift-prec))
|
||||
(list shift))
|
||||
(else null)))
|
||||
(else actions))))
|
||||
|
||||
;; resolve-sr-conflict : (listof action) (union int #f) -> (listof action)
|
||||
;; Resolves a single shift-reduce conflict, if precedences are in place.
|
||||
(define (resolve-sr-conflict/prec actions shift-prec)
|
||||
(define shift (if (shift? (car actions))
|
||||
(car actions)
|
||||
(cadr actions)))
|
||||
(define reduce (if (shift? (car actions))
|
||||
(cadr actions)
|
||||
(car actions)))
|
||||
(define reduce-prec (prod-prec (reduce-prod reduce)))
|
||||
(cond
|
||||
[(and shift-prec reduce-prec)
|
||||
(cond
|
||||
[(< (prec-num shift-prec) (prec-num reduce-prec))
|
||||
(list reduce)]
|
||||
[(> (prec-num shift-prec) (prec-num reduce-prec))
|
||||
(list shift)]
|
||||
[(eq? 'left (prec-assoc shift-prec))
|
||||
(list reduce)]
|
||||
[(eq? 'right (prec-assoc shift-prec))
|
||||
(list shift)]
|
||||
[else null])]
|
||||
[else actions]))
|
||||
|
||||
;; resolve-prec-conflicts : parse-table -> grouped-parse-table
|
||||
(define (resolve-prec-conflicts table)
|
||||
(table-map
|
||||
(lambda (gs actions)
|
||||
(cond
|
||||
((and (term? gs)
|
||||
(= 2 (length actions))
|
||||
(or (shift? (car actions))
|
||||
(shift? (cadr actions))))
|
||||
(resolve-sr-conflict/prec actions (term-prec gs)))
|
||||
(else actions)))
|
||||
(group-table table)))
|
||||
|
||||
;; build-table: grammar string bool -> parse-table
|
||||
(define (build-table g file suppress)
|
||||
(let* ((a (build-lr0-automaton g))
|
||||
(term-vector (list->vector (send g get-terms)))
|
||||
(end-terms (send g get-end-terms))
|
||||
(table (make-parse-table (send a get-num-states)))
|
||||
(get-lookahead (compute-LA a g))
|
||||
(reduce-cache (make-hash)))
|
||||
;; resolve-prec-conflicts : parse-table -> grouped-parse-table
|
||||
(define (resolve-prec-conflicts table)
|
||||
(table-map
|
||||
(λ (gs actions)
|
||||
(cond
|
||||
[(and (term? gs)
|
||||
(= 2 (length actions))
|
||||
(or (shift? (car actions))
|
||||
(shift? (cadr actions))))
|
||||
(resolve-sr-conflict/prec actions (term-prec gs))]
|
||||
[else actions]))
|
||||
(group-table table)))
|
||||
|
||||
(for-each
|
||||
(lambda (trans-key/state)
|
||||
(let ((from-state-index (kernel-index (trans-key-st (car trans-key/state))))
|
||||
(gs (trans-key-gs (car trans-key/state)))
|
||||
(to-state (cdr trans-key/state)))
|
||||
(table-add! table from-state-index gs
|
||||
(cond
|
||||
((non-term? gs)
|
||||
(make-goto (kernel-index to-state)))
|
||||
((member gs end-terms)
|
||||
(make-accept))
|
||||
(else
|
||||
(make-shift
|
||||
(kernel-index to-state)))))))
|
||||
(send a get-transitions))
|
||||
;; build-table: grammar string bool -> parse-table
|
||||
(define (build-table g file suppress)
|
||||
(define a (build-lr0-automaton g))
|
||||
(define term-vector (list->vector (send g get-terms)))
|
||||
(define end-terms (send g get-end-terms))
|
||||
(define table (make-parse-table (send a get-num-states)))
|
||||
(define get-lookahead (compute-LA a g))
|
||||
(define reduce-cache (make-hash))
|
||||
(for ([trans-key/state (in-list (send a get-transitions))])
|
||||
(define from-state-index (kernel-index (trans-key-st (car trans-key/state))))
|
||||
(define gs (trans-key-gs (car trans-key/state)))
|
||||
(define to-state (cdr trans-key/state))
|
||||
|
||||
(send a for-each-state
|
||||
(lambda (state)
|
||||
(for-each
|
||||
(lambda (item)
|
||||
(let ((item-prod (item-prod item)))
|
||||
(bit-vector-for-each
|
||||
(lambda (term-index)
|
||||
(unless (start-item? item)
|
||||
(let ((r (hash-ref reduce-cache item-prod
|
||||
(lambda ()
|
||||
(let ((r (make-reduce item-prod)))
|
||||
(hash-set! reduce-cache item-prod r)
|
||||
r)))))
|
||||
(table-add! table
|
||||
(kernel-index state)
|
||||
(vector-ref term-vector term-index)
|
||||
r))))
|
||||
(get-lookahead state item-prod))))
|
||||
(append (hash-ref (send a get-epsilon-trans) state (lambda () null))
|
||||
(filter (lambda (item)
|
||||
(not (move-dot-right item)))
|
||||
(kernel-items state))))))
|
||||
(table-add! table from-state-index gs
|
||||
(cond
|
||||
((non-term? gs)
|
||||
(make-goto (kernel-index to-state)))
|
||||
((member gs end-terms)
|
||||
(make-accept))
|
||||
(else
|
||||
(make-shift
|
||||
(kernel-index to-state))))))
|
||||
(send a for-each-state
|
||||
(λ (state)
|
||||
(for ([item (in-list (append (hash-ref (send a get-epsilon-trans) state (λ () null))
|
||||
(filter (λ (item)
|
||||
(not (move-dot-right item)))
|
||||
(kernel-items state))))])
|
||||
(let ([item-prod (item-prod item)])
|
||||
(bit-vector-for-each
|
||||
(λ (term-index)
|
||||
(unless (start-item? item)
|
||||
(let ((r (hash-ref reduce-cache item-prod
|
||||
(λ ()
|
||||
(let ((r (make-reduce item-prod)))
|
||||
(hash-set! reduce-cache item-prod r)
|
||||
r)))))
|
||||
(table-add! table
|
||||
(kernel-index state)
|
||||
(vector-ref term-vector term-index)
|
||||
r))))
|
||||
(get-lookahead state item-prod))))))
|
||||
|
||||
(let ((grouped-table (resolve-prec-conflicts table)))
|
||||
(unless (string=? file "")
|
||||
(with-handlers [(exn:fail:filesystem?
|
||||
(lambda (e)
|
||||
(eprintf
|
||||
"Cannot write debug output to file \"~a\": ~a\n"
|
||||
file
|
||||
(exn-message e))))]
|
||||
(call-with-output-file file
|
||||
(lambda (port)
|
||||
(display-parser a grouped-table (send g get-prods) port))
|
||||
#:exists 'truncate)))
|
||||
(resolve-conflicts grouped-table suppress))))
|
||||
(define grouped-table (resolve-prec-conflicts table))
|
||||
(unless (string=? file "")
|
||||
(with-handlers [(exn:fail:filesystem?
|
||||
(λ (e)
|
||||
(eprintf
|
||||
"Cannot write debug output to file \"~a\": ~a\n"
|
||||
file
|
||||
(exn-message e))))]
|
||||
(call-with-output-file file
|
||||
(λ (port)
|
||||
(display-parser a grouped-table (send g get-prods) port))
|
||||
#:exists 'truncate)))
|
||||
(resolve-conflicts grouped-table suppress))
|
||||
|
@ -1,118 +1,71 @@
|
||||
(module yacc-helper mzscheme
|
||||
#lang racket/base
|
||||
(require (prefix-in rl: racket/list)
|
||||
"../private-lex/token-syntax.rkt")
|
||||
|
||||
(require mzlib/list
|
||||
"../private-lex/token-syntax.rkt")
|
||||
;; General helper routines
|
||||
(provide duplicate-list? remove-duplicates overlap? vector-andmap display-yacc)
|
||||
|
||||
;; General helper routines
|
||||
(define (vector-andmap pred vec)
|
||||
(for/and ([item (in-vector vec)])
|
||||
(pred vec)))
|
||||
|
||||
(provide duplicate-list? remove-duplicates overlap? vector-andmap display-yacc)
|
||||
;; duplicate-list?: symbol list -> #f | symbol
|
||||
;; returns a symbol that exists twice in l, or false if no such symbol
|
||||
;; exists
|
||||
(define (duplicate-list? syms)
|
||||
(rl:check-duplicates syms eq?))
|
||||
|
||||
(define (vector-andmap f v)
|
||||
(let loop ((i 0))
|
||||
(cond
|
||||
((= i (vector-length v)) #t)
|
||||
(else (if (f (vector-ref v i))
|
||||
(loop (add1 i))
|
||||
#f)))))
|
||||
;; remove-duplicates: syntax-object list -> syntax-object list
|
||||
;; removes the duplicates from the lists
|
||||
(define (remove-duplicates syms)
|
||||
(rl:remove-duplicates syms equal? #:key syntax->datum))
|
||||
|
||||
;; duplicate-list?: symbol list -> #f | symbol
|
||||
;; returns a symbol that exists twice in l, or false if no such symbol
|
||||
;; exists
|
||||
(define (duplicate-list? l)
|
||||
(letrec ((t (make-hash-table))
|
||||
(dl? (lambda (l)
|
||||
(cond
|
||||
((null? l) #f)
|
||||
((hash-table-get t (car l) (lambda () #f)) =>
|
||||
(lambda (x) x))
|
||||
(else
|
||||
(hash-table-put! t (car l) (car l))
|
||||
(dl? (cdr l)))))))
|
||||
(dl? l)))
|
||||
;; overlap?: symbol list * symbol list -> #f | symbol
|
||||
;; Returns an symbol in l1 intersect l2, or #f is no such symbol exists
|
||||
(define (overlap? syms1 syms2)
|
||||
(for/first ([sym1 (in-list syms1)]
|
||||
#:when (memq sym1 syms2))
|
||||
sym1))
|
||||
|
||||
;; remove-duplicates: syntax-object list -> syntax-object list
|
||||
;; removes the duplicates from the lists
|
||||
(define (remove-duplicates sl)
|
||||
(let ((t (make-hash-table)))
|
||||
(letrec ((x
|
||||
(lambda (sl)
|
||||
(cond
|
||||
((null? sl) sl)
|
||||
((hash-table-get t (syntax-object->datum (car sl)) (lambda () #f))
|
||||
(x (cdr sl)))
|
||||
(else
|
||||
(hash-table-put! t (syntax-object->datum (car sl)) #t)
|
||||
(cons (car sl) (x (cdr sl))))))))
|
||||
(x sl))))
|
||||
|
||||
;; overlap?: symbol list * symbol list -> #f | symbol
|
||||
;; Returns an symbol in l1 intersect l2, or #f is no such symbol exists
|
||||
(define (overlap? l1 l2)
|
||||
(let/ec ret
|
||||
(let ((t (make-hash-table)))
|
||||
(for-each (lambda (s1)
|
||||
(hash-table-put! t s1 s1))
|
||||
l1)
|
||||
(for-each (lambda (s2)
|
||||
(cond
|
||||
((hash-table-get t s2 (lambda () #f)) =>
|
||||
(lambda (o) (ret o)))))
|
||||
l2)
|
||||
#f)))
|
||||
(define (display-yacc grammar tokens start precs port)
|
||||
(let-syntax ([p (syntax-rules ()
|
||||
((_ args ...) (fprintf port args ...)))])
|
||||
(let* ([tokens (map syntax-local-value tokens)]
|
||||
[eterms (filter e-terminals-def? tokens)]
|
||||
[terms (filter terminals-def? tokens)]
|
||||
[term-table (make-hasheq)]
|
||||
[display-rhs
|
||||
(λ (rhs)
|
||||
(for ([sym (in-list (car rhs))])
|
||||
(p "~a " (hash-ref term-table sym (λ () sym))))
|
||||
(when (= 3 (length rhs))
|
||||
(p "%prec ~a" (cadadr rhs)))
|
||||
(p "\n"))])
|
||||
(for* ([t (in-list eterms)]
|
||||
[t (in-list (syntax->datum (e-terminals-def-t t)))])
|
||||
(hash-set! term-table t (format "'~a'" t)))
|
||||
(for* ([t (in-list terms)]
|
||||
[t (in-list (syntax->datum (terminals-def-t t)))])
|
||||
(p "%token ~a\n" t)
|
||||
(hash-set! term-table t (format "~a" t)))
|
||||
(when precs
|
||||
(for ([prec (in-list precs)])
|
||||
(p "%~a " (car prec))
|
||||
(for ([tok (in-list (cdr prec))])
|
||||
(p " ~a" (hash-ref term-table tok)))
|
||||
(p "\n")))
|
||||
(p "%start ~a\n" start)
|
||||
(p "%%\n")
|
||||
(for ([prod (in-list grammar)])
|
||||
(define nt (car prod))
|
||||
(p "~a: " nt)
|
||||
(display-rhs (cadr prod))
|
||||
(for ([rhs (in-list (cddr prod))])
|
||||
(p "| ")
|
||||
(display-rhs rhs))
|
||||
(p ";\n"))
|
||||
(p "%%\n"))))
|
||||
|
||||
|
||||
(define (display-yacc grammar tokens start precs port)
|
||||
(let-syntax ((p (syntax-rules ()
|
||||
((_ args ...) (fprintf port args ...)))))
|
||||
(let* ((tokens (map syntax-local-value tokens))
|
||||
(eterms (filter e-terminals-def? tokens))
|
||||
(terms (filter terminals-def? tokens))
|
||||
(term-table (make-hash-table))
|
||||
(display-rhs
|
||||
(lambda (rhs)
|
||||
(for-each (lambda (sym) (p "~a " (hash-table-get term-table sym (lambda () sym))))
|
||||
(car rhs))
|
||||
(if (= 3 (length rhs))
|
||||
(p "%prec ~a" (cadadr rhs)))
|
||||
(p "\n"))))
|
||||
(for-each
|
||||
(lambda (t)
|
||||
(for-each
|
||||
(lambda (t)
|
||||
(hash-table-put! term-table t (format "'~a'" t)))
|
||||
(syntax-object->datum (e-terminals-def-t t))))
|
||||
eterms)
|
||||
(for-each
|
||||
(lambda (t)
|
||||
(for-each
|
||||
(lambda (t)
|
||||
(p "%token ~a\n" t)
|
||||
(hash-table-put! term-table t (format "~a" t)))
|
||||
(syntax-object->datum (terminals-def-t t))))
|
||||
terms)
|
||||
(if precs
|
||||
(for-each (lambda (prec)
|
||||
(p "%~a " (car prec))
|
||||
(for-each (lambda (tok)
|
||||
(p " ~a" (hash-table-get term-table tok)))
|
||||
(cdr prec))
|
||||
(p "\n"))
|
||||
precs))
|
||||
(p "%start ~a\n" start)
|
||||
(p "%%\n")
|
||||
|
||||
(for-each (lambda (prod)
|
||||
(let ((nt (car prod)))
|
||||
(p "~a: " nt)
|
||||
(display-rhs (cadr prod))
|
||||
(for-each (lambda (rhs)
|
||||
(p "| ")
|
||||
(display-rhs rhs))
|
||||
(cddr prod))
|
||||
(p ";\n")))
|
||||
grammar)
|
||||
(p "%%\n"))))
|
||||
|
||||
|
||||
)
|
||||
|
||||
|
@ -1,135 +1,130 @@
|
||||
(module yacc-to-scheme mzscheme
|
||||
(require br-parser-tools/lex
|
||||
(prefix : br-parser-tools/lex-sre)
|
||||
br-parser-tools/yacc
|
||||
syntax/readerr
|
||||
mzlib/list)
|
||||
(provide trans)
|
||||
#lang racket/base
|
||||
(require br-parser-tools/lex
|
||||
(prefix-in : br-parser-tools/lex-sre)
|
||||
br-parser-tools/yacc
|
||||
syntax/readerr
|
||||
racket/list)
|
||||
(provide trans)
|
||||
|
||||
(define match-double-string
|
||||
(lexer
|
||||
((:+ (:~ #\" #\\)) (append (string->list lexeme)
|
||||
(match-double-string input-port)))
|
||||
((:: #\\ any-char) (cons (string-ref lexeme 1) (match-double-string input-port)))
|
||||
(#\" null)))
|
||||
(define match-double-string
|
||||
(lexer
|
||||
[(:+ (:~ #\" #\\)) (append (string->list lexeme)
|
||||
(match-double-string input-port))]
|
||||
[(:: #\\ any-char) (cons (string-ref lexeme 1) (match-double-string input-port))]
|
||||
[#\" null]))
|
||||
|
||||
(define match-single-string
|
||||
(lexer
|
||||
((:+ (:~ #\' #\\)) (append (string->list lexeme)
|
||||
(match-single-string input-port)))
|
||||
((:: #\\ any-char) (cons (string-ref lexeme 1) (match-single-string input-port)))
|
||||
(#\' null)))
|
||||
(define match-single-string
|
||||
(lexer
|
||||
[(:+ (:~ #\' #\\)) (append (string->list lexeme)
|
||||
(match-single-string input-port))]
|
||||
[(:: #\\ any-char) (cons (string-ref lexeme 1) (match-single-string input-port))]
|
||||
[#\' null]))
|
||||
|
||||
(define-lex-abbrevs
|
||||
(letter (:or (:/ "a" "z") (:/ "A" "Z")))
|
||||
(digit (:/ "0" "9"))
|
||||
(initial (:or letter (char-set "!$%&*/<=>?^_~@")))
|
||||
(subsequent (:or initial digit (char-set "+-.@")))
|
||||
(comment (:: "/*" (complement (:: any-string "*/" any-string)) "*/")))
|
||||
(define-lex-abbrevs
|
||||
[letter (:or (:/ "a" "z") (:/ "A" "Z"))]
|
||||
[digit (:/ "0" "9")]
|
||||
[initial (:or letter (char-set "!$%&*/<=>?^_~@"))]
|
||||
[subsequent (:or initial digit (char-set "+-.@"))]
|
||||
[comment (:: "/*" (complement (:: any-string "*/" any-string)) "*/")])
|
||||
|
||||
(define-empty-tokens x
|
||||
(EOF PIPE |:| SEMI |%%| %prec))
|
||||
(define-tokens y
|
||||
(SYM STRING))
|
||||
(define-empty-tokens x (EOF PIPE |:| SEMI |%%| %prec))
|
||||
(define-tokens y (SYM STRING))
|
||||
|
||||
(define get-token-grammar
|
||||
(lexer-src-pos
|
||||
("%%" '|%%|)
|
||||
(":" (string->symbol lexeme))
|
||||
("%prec" (string->symbol lexeme))
|
||||
(#\| 'PIPE)
|
||||
((:+ (:or #\newline #\tab " " comment (:: "{" (:* (:~ "}")) "}")))
|
||||
(return-without-pos (get-token-grammar input-port)))
|
||||
(#\; 'SEMI)
|
||||
(#\' (token-STRING (string->symbol (list->string (match-single-string input-port)))))
|
||||
(#\" (token-STRING (string->symbol (list->string (match-double-string input-port)))))
|
||||
((:: initial (:* subsequent)) (token-SYM (string->symbol lexeme)))))
|
||||
(define get-token-grammar
|
||||
(lexer-src-pos
|
||||
["%%" '|%%|]
|
||||
[":" (string->symbol lexeme)]
|
||||
["%prec" (string->symbol lexeme)]
|
||||
[#\| 'PIPE]
|
||||
[(:+ (:or #\newline #\tab " " comment (:: "{" (:* (:~ "}")) "}")))
|
||||
(return-without-pos (get-token-grammar input-port))]
|
||||
[#\; 'SEMI]
|
||||
[#\' (token-STRING (string->symbol (list->string (match-single-string input-port))))]
|
||||
[#\" (token-STRING (string->symbol (list->string (match-double-string input-port))))]
|
||||
[(:: initial (:* subsequent)) (token-SYM (string->symbol lexeme))]))
|
||||
|
||||
(define (parse-grammar enter-term enter-empty-term enter-non-term)
|
||||
(parser
|
||||
(tokens x y)
|
||||
(src-pos)
|
||||
(error (lambda (tok-ok tok-name tok-value start-pos end-pos)
|
||||
(raise-read-error
|
||||
(format "Error Parsing YACC grammar at token: ~a with value: ~a" tok-name tok-value)
|
||||
(file-path)
|
||||
(position-line start-pos)
|
||||
(position-col start-pos)
|
||||
(position-offset start-pos)
|
||||
(- (position-offset end-pos) (position-offset start-pos)))))
|
||||
(define (parse-grammar enter-term enter-empty-term enter-non-term)
|
||||
(parser
|
||||
(tokens x y)
|
||||
(src-pos)
|
||||
(error (λ (tok-ok tok-name tok-value start-pos end-pos)
|
||||
(raise-read-error
|
||||
(format "Error Parsing YACC grammar at token: ~a with value: ~a" tok-name tok-value)
|
||||
(file-path)
|
||||
(position-line start-pos)
|
||||
(position-col start-pos)
|
||||
(position-offset start-pos)
|
||||
(- (position-offset end-pos) (position-offset start-pos)))))
|
||||
|
||||
(end |%%|)
|
||||
(start gram)
|
||||
(grammar
|
||||
(gram
|
||||
((production) (list $1))
|
||||
((production gram) (cons $1 $2)))
|
||||
(production
|
||||
((SYM |:| prods SEMI)
|
||||
(begin
|
||||
(enter-non-term $1)
|
||||
(cons $1 $3))))
|
||||
(prods
|
||||
((rhs) (list `(,$1 #f)))
|
||||
((rhs prec) (list `(,$1 ,$2 #f)))
|
||||
((rhs PIPE prods) (cons `(,$1 #f) $3))
|
||||
((rhs prec PIPE prods) (cons `(,$1 ,$2 #f) $4)))
|
||||
(prec
|
||||
((%prec SYM)
|
||||
(begin
|
||||
(enter-term $2)
|
||||
(list 'prec $2)))
|
||||
((%prec STRING)
|
||||
(begin
|
||||
(enter-empty-term $2)
|
||||
(list 'prec $2))))
|
||||
(rhs
|
||||
(() null)
|
||||
((SYM rhs)
|
||||
(begin
|
||||
(enter-term $1)
|
||||
(cons $1 $2)))
|
||||
((STRING rhs)
|
||||
(begin
|
||||
(enter-empty-term $1)
|
||||
(cons $1 $2)))))))
|
||||
(end |%%|)
|
||||
(start gram)
|
||||
(grammar
|
||||
(gram
|
||||
((production) (list $1))
|
||||
((production gram) (cons $1 $2)))
|
||||
(production
|
||||
((SYM |:| prods SEMI)
|
||||
(begin
|
||||
(enter-non-term $1)
|
||||
(cons $1 $3))))
|
||||
(prods
|
||||
((rhs) (list `(,$1 #f)))
|
||||
((rhs prec) (list `(,$1 ,$2 #f)))
|
||||
((rhs PIPE prods) (cons `(,$1 #f) $3))
|
||||
((rhs prec PIPE prods) (cons `(,$1 ,$2 #f) $4)))
|
||||
(prec
|
||||
((%prec SYM)
|
||||
(begin
|
||||
(enter-term $2)
|
||||
(list 'prec $2)))
|
||||
((%prec STRING)
|
||||
(begin
|
||||
(enter-empty-term $2)
|
||||
(list 'prec $2))))
|
||||
(rhs
|
||||
(() null)
|
||||
((SYM rhs)
|
||||
(begin
|
||||
(enter-term $1)
|
||||
(cons $1 $2)))
|
||||
((STRING rhs)
|
||||
(begin
|
||||
(enter-empty-term $1)
|
||||
(cons $1 $2)))))))
|
||||
|
||||
(define (symbol<? a b)
|
||||
(string<? (symbol->string a) (symbol->string b)))
|
||||
(define (symbol<? a b)
|
||||
(string<? (symbol->string a) (symbol->string b)))
|
||||
|
||||
(define (trans filename)
|
||||
(let* ((i (open-input-file filename))
|
||||
(terms (make-hash-table))
|
||||
(eterms (make-hash-table))
|
||||
(nterms (make-hash-table))
|
||||
(enter-term
|
||||
(lambda (s)
|
||||
(if (not (hash-table-get nterms s (lambda () #f)))
|
||||
(hash-table-put! terms s #t))))
|
||||
(enter-empty-term
|
||||
(lambda (s)
|
||||
(if (not (hash-table-get nterms s (lambda () #f)))
|
||||
(hash-table-put! eterms s #t))))
|
||||
(enter-non-term
|
||||
(lambda (s)
|
||||
(hash-table-remove! terms s)
|
||||
(hash-table-remove! eterms s)
|
||||
(hash-table-put! nterms s #t))))
|
||||
(port-count-lines! i)
|
||||
(file-path filename)
|
||||
(regexp-match "%%" i)
|
||||
(begin0
|
||||
(let ((gram ((parse-grammar enter-term enter-empty-term enter-non-term)
|
||||
(lambda ()
|
||||
(let ((t (get-token-grammar i)))
|
||||
t)))))
|
||||
`(begin
|
||||
(define-tokens t ,(sort (hash-table-map terms (lambda (k v) k)) symbol<?))
|
||||
(define-empty-tokens et ,(sort (hash-table-map eterms (lambda (k v) k)) symbol<?))
|
||||
(parser
|
||||
(start ___)
|
||||
(end ___)
|
||||
(error ___)
|
||||
(tokens t et)
|
||||
(grammar ,@gram))))
|
||||
(close-input-port i)))))
|
||||
(define (trans filename)
|
||||
(define i (open-input-file filename))
|
||||
(define terms (make-hasheq))
|
||||
(define eterms (make-hasheq))
|
||||
(define nterms (make-hasheq))
|
||||
(define (enter-term s)
|
||||
(when (not (hash-ref nterms s (λ () #f)))
|
||||
(hash-set! terms s #t)))
|
||||
(define (enter-empty-term s)
|
||||
(when (not (hash-ref nterms s (λ () #f)))
|
||||
(hash-set! eterms s #t)))
|
||||
(define (enter-non-term s)
|
||||
(hash-remove! terms s)
|
||||
(hash-remove! eterms s)
|
||||
(hash-set! nterms s #t))
|
||||
(port-count-lines! i)
|
||||
(file-path filename)
|
||||
(regexp-match "%%" i)
|
||||
(begin0
|
||||
(let ([gram ((parse-grammar enter-term enter-empty-term enter-non-term)
|
||||
(λ ()
|
||||
(let ((t (get-token-grammar i)))
|
||||
t)))])
|
||||
`(begin
|
||||
(define-tokens t ,(sort (hash-map terms (λ (k v) k)) symbol<?))
|
||||
(define-empty-tokens et ,(sort (hash-map eterms (λ (k v) k)) symbol<?))
|
||||
(parser
|
||||
(start ___)
|
||||
(end ___)
|
||||
(error ___)
|
||||
(tokens t et)
|
||||
(grammar ,@gram))))
|
||||
(close-input-port i)))
|
||||
|
Loading…
Reference in New Issue