951 lines
27 KiB
Scheme
951 lines
27 KiB
Scheme
; Hacked to change error to fatal-error.
|
|
; (One of the benchmarked systems has a problem with calls to error.)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;
|
|
; Parsing benchmark.
|
|
;
|
|
; Reads nboyer.sch into a string before timing begins.
|
|
;
|
|
; The timed portion of the benchmark parses the string
|
|
; representation of nboyer.sch 1000 times.
|
|
;
|
|
; The output of that parse is checked by comparing it
|
|
; the the value returned by the read procedure.
|
|
;
|
|
; Usage:
|
|
; (parsing-benchmark n input)
|
|
;
|
|
; n defaults to 1000, and input defaults to "nboyer.sch".
|
|
;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (parsing-benchmark . rest)
|
|
(let* ((n (if (null? rest) 1000 (car rest)))
|
|
(input (if (or (null? rest) (null? (cdr rest)))
|
|
"nboyer.sch"
|
|
(cadr rest)))
|
|
(input-string (read-file-as-string input))
|
|
(answer (call-with-input-file
|
|
input
|
|
(lambda (in)
|
|
(do ((x (read in) (read in))
|
|
(answer '() x))
|
|
((eof-object? x)
|
|
answer)))))
|
|
(benchmark-name
|
|
(string-append "parsing:" input ":" (number->string n))))
|
|
(run-benchmark benchmark-name
|
|
n
|
|
(lambda (x) (equal? x answer))
|
|
(lambda (input-string)
|
|
(lambda () (parse-string input-string)))
|
|
input-string)))
|
|
|
|
(define (read-from-string-port-benchmark . rest)
|
|
(let* ((n (if (null? rest) 1000 (car rest)))
|
|
(input (if (or (null? rest) (null? (cdr rest)))
|
|
"nboyer.sch"
|
|
(cadr rest)))
|
|
(input-string (read-file-as-string input))
|
|
(answer (call-with-input-file
|
|
input
|
|
(lambda (in)
|
|
(do ((x (read in) (read in))
|
|
(answer '() x))
|
|
((eof-object? x)
|
|
answer)))))
|
|
(benchmark-name
|
|
(string-append "reading:" input ":" (number->string n))))
|
|
(run-benchmark benchmark-name
|
|
n
|
|
(lambda ()
|
|
(let ((in (open-input-string input-string)))
|
|
(do ((x (read in) (read in))
|
|
(y #f x))
|
|
((eof-object? x) y))))
|
|
(lambda (x) (equal? x answer)))))
|
|
|
|
(define (read-file-as-string name)
|
|
(call-with-input-file
|
|
name
|
|
(lambda (in)
|
|
(do ((x (read-char in) (read-char in))
|
|
(chars '() (cons x chars)))
|
|
((eof-object? x)
|
|
(list->string (reverse chars)))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;
|
|
; The parser used for benchmarking.
|
|
;
|
|
; Given a string containing Scheme code, parses the entire
|
|
; string and returns the last <datum> read from the string.
|
|
;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (parse-string input-string)
|
|
|
|
; Constants and local variables.
|
|
|
|
(let* (; Constants.
|
|
|
|
; Any character that doesn't appear within nboyer.sch
|
|
; (or the input file, if different) can be used to
|
|
; represent end-of-file.
|
|
|
|
(eof #\~)
|
|
|
|
; length of longest token allowed
|
|
; (this allows static allocation in C)
|
|
|
|
(max_token_size 1024)
|
|
|
|
; Encodings of error messages.
|
|
|
|
(errLongToken 1) ; extremely long token
|
|
(errincompletetoken 2) ; any lexical error, really
|
|
(errLexGenBug 3) ; can't happen
|
|
|
|
; State for one-token buffering in lexical analyzer.
|
|
|
|
(kindOfNextToken 'z1) ; valid iff nextTokenIsReady
|
|
(nextTokenIsReady #f)
|
|
|
|
(tokenValue "") ; string associated with current token
|
|
|
|
(totalErrors 0) ; errors so far
|
|
(lineNumber 1) ; rudimentary source code location
|
|
(lineNumberOfLastError 0) ; ditto
|
|
|
|
; A string buffer for the characters of the current token.
|
|
|
|
(string_accumulator (make-string max_token_size))
|
|
|
|
; Number of characters in string_accumulator.
|
|
|
|
(string_accumulator_length 0)
|
|
|
|
; A single character of buffering.
|
|
; nextCharacter is valid iff nextCharacterIsReady
|
|
|
|
(nextCharacter #\space)
|
|
(nextCharacterIsReady #f)
|
|
|
|
; Index of next character to be read from input-string.
|
|
|
|
(input-index 0)
|
|
|
|
(input-length (string-length input-string))
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;
|
|
; LexGen generated the code for the state machine.
|
|
;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (scanner0)
|
|
(let loop ((c (scanchar)))
|
|
(if (char-whitespace? c)
|
|
(begin
|
|
(consumechar)
|
|
(set! string_accumulator_length 0)
|
|
(loop (scanchar)))))
|
|
(let ((c (scanchar)))
|
|
(if (char=? c eof) (accept 'eof) (state0 c))))
|
|
|
|
(define (state0 c)
|
|
(case c
|
|
((#\`) (consumechar) (accept 'backquote))
|
|
((#\') (consumechar) (accept 'quote))
|
|
((#\)) (consumechar) (accept 'rparen))
|
|
((#\() (consumechar) (accept 'lparen))
|
|
((#\;) (consumechar) (state29 (scanchar)))
|
|
((#\+ #\-) (consumechar) (state28 (scanchar)))
|
|
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
|
(consumechar)
|
|
(state27 (scanchar)))
|
|
((#\.) (consumechar) (state16 (scanchar)))
|
|
((#\a
|
|
#\b
|
|
#\c
|
|
#\d
|
|
#\e
|
|
#\f
|
|
#\g
|
|
#\h
|
|
#\i
|
|
#\j
|
|
#\k
|
|
#\l
|
|
#\m
|
|
#\n
|
|
#\o
|
|
#\p
|
|
#\q
|
|
#\r
|
|
#\s
|
|
#\t
|
|
#\u
|
|
#\v
|
|
#\w
|
|
#\x
|
|
#\y
|
|
#\z
|
|
#\A
|
|
#\B
|
|
#\C
|
|
#\D
|
|
#\E
|
|
#\F
|
|
#\G
|
|
#\H
|
|
#\I
|
|
#\J
|
|
#\K
|
|
#\L
|
|
#\M
|
|
#\N
|
|
#\O
|
|
#\P
|
|
#\Q
|
|
#\R
|
|
#\S
|
|
#\T
|
|
#\U
|
|
#\V
|
|
#\W
|
|
#\X
|
|
#\Y
|
|
#\Z
|
|
#\!
|
|
#\$
|
|
#\%
|
|
#\&
|
|
#\*
|
|
#\/
|
|
#\:
|
|
#\<
|
|
#\=
|
|
#\>
|
|
#\?
|
|
#\^
|
|
#\_
|
|
#\~)
|
|
(consumechar)
|
|
(state14 (scanchar)))
|
|
((#\#) (consumechar) (state13 (scanchar)))
|
|
((#\") (consumechar) (state2 (scanchar)))
|
|
((#\,) (consumechar) (state1 (scanchar)))
|
|
(else
|
|
(if (char-whitespace? c)
|
|
(begin (consumechar) (state30 (scanchar)))
|
|
(scannererror errincompletetoken)))))
|
|
(define (state1 c)
|
|
(case c
|
|
((#\@) (consumechar) (accept 'splicing))
|
|
(else (accept 'comma))))
|
|
(define (state2 c)
|
|
(case c
|
|
((#\") (consumechar) (accept 'string))
|
|
(else
|
|
(if (isnotdoublequote? c)
|
|
(begin (consumechar) (state2 (scanchar)))
|
|
(scannererror errincompletetoken)))))
|
|
(define (state3 c)
|
|
(case c
|
|
((#\n) (consumechar) (state8 (scanchar)))
|
|
(else (scannererror errincompletetoken))))
|
|
(define (state4 c)
|
|
(case c
|
|
((#\i) (consumechar) (state3 (scanchar)))
|
|
(else (scannererror errincompletetoken))))
|
|
(define (state5 c)
|
|
(case c
|
|
((#\l) (consumechar) (state4 (scanchar)))
|
|
(else (scannererror errincompletetoken))))
|
|
(define (state6 c)
|
|
(case c
|
|
((#\w) (consumechar) (state5 (scanchar)))
|
|
(else (scannererror errincompletetoken))))
|
|
(define (state7 c)
|
|
(case c
|
|
((#\e) (consumechar) (state6 (scanchar)))
|
|
(else (scannererror errincompletetoken))))
|
|
(define (state8 c)
|
|
(case c
|
|
((#\e) (consumechar) (accept 'character))
|
|
(else (scannererror errincompletetoken))))
|
|
(define (state9 c)
|
|
(case c
|
|
((#\c) (consumechar) (state8 (scanchar)))
|
|
(else (scannererror errincompletetoken))))
|
|
(define (state10 c)
|
|
(case c
|
|
((#\a) (consumechar) (state9 (scanchar)))
|
|
(else (scannererror errincompletetoken))))
|
|
(define (state11 c)
|
|
(case c
|
|
((#\p) (consumechar) (state10 (scanchar)))
|
|
(else (scannererror errincompletetoken))))
|
|
(define (state12 c)
|
|
(case c
|
|
((#\s) (consumechar) (state11 (scanchar)))
|
|
((#\n) (consumechar) (state7 (scanchar)))
|
|
(else
|
|
(if (char? c)
|
|
(begin (consumechar) (accept 'character))
|
|
(scannererror errincompletetoken)))))
|
|
(define (state13 c)
|
|
(case c
|
|
((#\() (consumechar) (accept 'vecstart))
|
|
((#\t #\f) (consumechar) (accept 'boolean))
|
|
((#\\) (consumechar) (state12 (scanchar)))
|
|
(else (scannererror errincompletetoken))))
|
|
(define (state14 c)
|
|
(case c
|
|
((#\a
|
|
#\b
|
|
#\c
|
|
#\d
|
|
#\e
|
|
#\f
|
|
#\g
|
|
#\h
|
|
#\i
|
|
#\j
|
|
#\k
|
|
#\l
|
|
#\m
|
|
#\n
|
|
#\o
|
|
#\p
|
|
#\q
|
|
#\r
|
|
#\s
|
|
#\t
|
|
#\u
|
|
#\v
|
|
#\w
|
|
#\x
|
|
#\y
|
|
#\z
|
|
#\A
|
|
#\B
|
|
#\C
|
|
#\D
|
|
#\E
|
|
#\F
|
|
#\G
|
|
#\H
|
|
#\I
|
|
#\J
|
|
#\K
|
|
#\L
|
|
#\M
|
|
#\N
|
|
#\O
|
|
#\P
|
|
#\Q
|
|
#\R
|
|
#\S
|
|
#\T
|
|
#\U
|
|
#\V
|
|
#\W
|
|
#\X
|
|
#\Y
|
|
#\Z
|
|
#\!
|
|
#\$
|
|
#\%
|
|
#\&
|
|
#\*
|
|
#\/
|
|
#\:
|
|
#\<
|
|
#\=
|
|
#\>
|
|
#\?
|
|
#\^
|
|
#\_
|
|
#\~
|
|
#\0
|
|
#\1
|
|
#\2
|
|
#\3
|
|
#\4
|
|
#\5
|
|
#\6
|
|
#\7
|
|
#\8
|
|
#\9
|
|
#\+
|
|
#\-
|
|
#\.
|
|
#\@)
|
|
(consumechar)
|
|
(state14 (scanchar)))
|
|
(else (accept 'id))))
|
|
(define (state15 c)
|
|
(case c
|
|
((#\.) (consumechar) (accept 'id))
|
|
(else (scannererror errincompletetoken))))
|
|
(define (state16 c)
|
|
(case c
|
|
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
|
(consumechar)
|
|
(state18 (scanchar)))
|
|
((#\.) (consumechar) (state15 (scanchar)))
|
|
(else (accept 'period))))
|
|
(define (state17 c)
|
|
(case c
|
|
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
|
(consumechar)
|
|
(state18 (scanchar)))
|
|
(else (scannererror errincompletetoken))))
|
|
(define (state18 c)
|
|
(case c
|
|
((#\e #\s #\f #\d #\l)
|
|
(consumechar)
|
|
(state22 (scanchar)))
|
|
((#\#) (consumechar) (state19 (scanchar)))
|
|
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
|
(consumechar)
|
|
(state18 (scanchar)))
|
|
(else (accept 'number))))
|
|
(define (state19 c)
|
|
(case c
|
|
((#\e #\s #\f #\d #\l)
|
|
(consumechar)
|
|
(state22 (scanchar)))
|
|
((#\#) (consumechar) (state19 (scanchar)))
|
|
(else (accept 'number))))
|
|
(define (state20 c)
|
|
(case c
|
|
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
|
(consumechar)
|
|
(state20 (scanchar)))
|
|
(else (accept 'number))))
|
|
(define (state21 c)
|
|
(case c
|
|
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
|
(consumechar)
|
|
(state20 (scanchar)))
|
|
(else (scannererror errincompletetoken))))
|
|
(define (state22 c)
|
|
(case c
|
|
((#\+ #\-) (consumechar) (state21 (scanchar)))
|
|
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
|
(consumechar)
|
|
(state20 (scanchar)))
|
|
(else (scannererror errincompletetoken))))
|
|
(define (state23 c)
|
|
(case c
|
|
((#\#) (consumechar) (state23 (scanchar)))
|
|
(else (accept 'number))))
|
|
(define (state24 c)
|
|
(case c
|
|
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
|
(consumechar)
|
|
(state24 (scanchar)))
|
|
((#\#) (consumechar) (state23 (scanchar)))
|
|
(else (accept 'number))))
|
|
(define (state25 c)
|
|
(case c
|
|
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
|
(consumechar)
|
|
(state24 (scanchar)))
|
|
(else (scannererror errincompletetoken))))
|
|
(define (state26 c)
|
|
(case c
|
|
((#\#) (consumechar) (state26 (scanchar)))
|
|
((#\/) (consumechar) (state25 (scanchar)))
|
|
((#\e #\s #\f #\d #\l)
|
|
(consumechar)
|
|
(state22 (scanchar)))
|
|
((#\.) (consumechar) (state19 (scanchar)))
|
|
(else (accept 'number))))
|
|
(define (state27 c)
|
|
(case c
|
|
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
|
(consumechar)
|
|
(state27 (scanchar)))
|
|
((#\#) (consumechar) (state26 (scanchar)))
|
|
((#\/) (consumechar) (state25 (scanchar)))
|
|
((#\e #\s #\f #\d #\l)
|
|
(consumechar)
|
|
(state22 (scanchar)))
|
|
((#\.) (consumechar) (state18 (scanchar)))
|
|
(else (accept 'number))))
|
|
(define (state28 c)
|
|
(case c
|
|
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
|
(consumechar)
|
|
(state27 (scanchar)))
|
|
((#\.) (consumechar) (state17 (scanchar)))
|
|
(else (accept 'id))))
|
|
(define (state29 c)
|
|
(case c
|
|
((#\newline)
|
|
(consumechar)
|
|
(begin
|
|
(set! string_accumulator_length 0)
|
|
(state0 (scanchar))))
|
|
(else
|
|
(if (isnotnewline? c)
|
|
(begin (consumechar) (state29 (scanchar)))
|
|
(scannererror errincompletetoken)))))
|
|
(define (state30 c)
|
|
(case c
|
|
(else
|
|
(if (char-whitespace? c)
|
|
(begin (consumechar) (state30 (scanchar)))
|
|
(begin
|
|
(set! string_accumulator_length 0)
|
|
(state0 (scanchar)))))))
|
|
(define (state31 c)
|
|
(case c
|
|
(else
|
|
(begin
|
|
(set! string_accumulator_length 0)
|
|
(state0 (scanchar))))))
|
|
(define (state32 c) (case c (else (accept 'id))))
|
|
(define (state33 c)
|
|
(case c (else (accept 'boolean))))
|
|
(define (state34 c)
|
|
(case c (else (accept 'character))))
|
|
(define (state35 c)
|
|
(case c (else (accept 'vecstart))))
|
|
(define (state36 c)
|
|
(case c (else (accept 'string))))
|
|
(define (state37 c)
|
|
(case c (else (accept 'lparen))))
|
|
(define (state38 c)
|
|
(case c (else (accept 'rparen))))
|
|
(define (state39 c)
|
|
(case c (else (accept 'quote))))
|
|
(define (state40 c)
|
|
(case c (else (accept 'backquote))))
|
|
(define (state41 c)
|
|
(case c (else (accept 'splicing))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;
|
|
; End of state machine generated by LexGen.
|
|
;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;
|
|
; ParseGen generated the code for the strong LL(1) parser.
|
|
;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (parse-datum)
|
|
(case (next-token)
|
|
((splicing comma backquote quote lparen vecstart)
|
|
(let ((ast1 (parse-compound-datum)))
|
|
(identity ast1)))
|
|
((boolean number character string id)
|
|
(let ((ast1 (parse-simple-datum)))
|
|
(identity ast1)))
|
|
(else
|
|
(parse-error
|
|
'<datum>
|
|
'(backquote
|
|
boolean
|
|
character
|
|
comma
|
|
id
|
|
lparen
|
|
number
|
|
quote
|
|
splicing
|
|
string
|
|
vecstart)))))
|
|
|
|
(define (parse-simple-datum)
|
|
(case (next-token)
|
|
((id)
|
|
(let ((ast1 (parse-symbol))) (identity ast1)))
|
|
((string) (begin (consume-token!) (makeString)))
|
|
((character) (begin (consume-token!) (makeChar)))
|
|
((number) (begin (consume-token!) (makeNum)))
|
|
((boolean) (begin (consume-token!) (makeBool)))
|
|
(else
|
|
(parse-error
|
|
'<simple-datum>
|
|
'(boolean character id number string)))))
|
|
|
|
(define (parse-symbol)
|
|
(case (next-token)
|
|
((id) (begin (consume-token!) (makeSym)))
|
|
(else (parse-error '<symbol> '(id)))))
|
|
|
|
(define (parse-compound-datum)
|
|
(case (next-token)
|
|
((vecstart)
|
|
(let ((ast1 (parse-vector))) (identity ast1)))
|
|
((lparen quote backquote comma splicing)
|
|
(let ((ast1 (parse-list))) (identity ast1)))
|
|
(else
|
|
(parse-error
|
|
'<compound-datum>
|
|
'(backquote comma lparen quote splicing vecstart)))))
|
|
|
|
(define (parse-list)
|
|
(case (next-token)
|
|
((splicing comma backquote quote)
|
|
(let ((ast1 (parse-abbreviation)))
|
|
(identity ast1)))
|
|
((lparen)
|
|
(begin
|
|
(consume-token!)
|
|
(let ((ast1 (parse-list2))) (identity ast1))))
|
|
(else
|
|
(parse-error
|
|
'<list>
|
|
'(backquote comma lparen quote splicing)))))
|
|
|
|
(define (parse-list2)
|
|
(case (next-token)
|
|
((id string
|
|
character
|
|
number
|
|
boolean
|
|
vecstart
|
|
lparen
|
|
quote
|
|
backquote
|
|
comma
|
|
splicing)
|
|
(let ((ast1 (parse-datum)))
|
|
(let ((ast2 (parse-list3))) (cons ast1 ast2))))
|
|
((rparen) (begin (consume-token!) (emptyList)))
|
|
(else
|
|
(parse-error
|
|
'<list2>
|
|
'(backquote
|
|
boolean
|
|
character
|
|
comma
|
|
id
|
|
lparen
|
|
number
|
|
quote
|
|
rparen
|
|
splicing
|
|
string
|
|
vecstart)))))
|
|
|
|
(define (parse-list3)
|
|
(case (next-token)
|
|
((rparen
|
|
period
|
|
splicing
|
|
comma
|
|
backquote
|
|
quote
|
|
lparen
|
|
vecstart
|
|
boolean
|
|
number
|
|
character
|
|
string
|
|
id)
|
|
(let ((ast1 (parse-data)))
|
|
(let ((ast2 (parse-list4)))
|
|
(pseudoAppend ast1 ast2))))
|
|
(else
|
|
(parse-error
|
|
'<list3>
|
|
'(backquote
|
|
boolean
|
|
character
|
|
comma
|
|
id
|
|
lparen
|
|
number
|
|
period
|
|
quote
|
|
rparen
|
|
splicing
|
|
string
|
|
vecstart)))))
|
|
|
|
(define (parse-list4)
|
|
(case (next-token)
|
|
((period)
|
|
(begin
|
|
(consume-token!)
|
|
(let ((ast1 (parse-datum)))
|
|
(if (eq? (next-token) 'rparen)
|
|
(begin (consume-token!) (identity ast1))
|
|
(parse-error '<list4> '(rparen))))))
|
|
((rparen) (begin (consume-token!) (emptyList)))
|
|
(else (parse-error '<list4> '(period rparen)))))
|
|
|
|
(define (parse-abbreviation)
|
|
(case (next-token)
|
|
((quote backquote comma splicing)
|
|
(let ((ast1 (parse-abbrev-prefix)))
|
|
(let ((ast2 (parse-datum))) (list ast1 ast2))))
|
|
(else
|
|
(parse-error
|
|
'<abbreviation>
|
|
'(backquote comma quote splicing)))))
|
|
|
|
(define (parse-abbrev-prefix)
|
|
(case (next-token)
|
|
((splicing)
|
|
(begin (consume-token!) (symSplicing)))
|
|
((comma) (begin (consume-token!) (symUnquote)))
|
|
((backquote)
|
|
(begin (consume-token!) (symBackquote)))
|
|
((quote) (begin (consume-token!) (symQuote)))
|
|
(else
|
|
(parse-error
|
|
'<abbrev-prefix>
|
|
'(backquote comma quote splicing)))))
|
|
|
|
(define (parse-vector)
|
|
(case (next-token)
|
|
((vecstart)
|
|
(begin
|
|
(consume-token!)
|
|
(let ((ast1 (parse-data)))
|
|
(if (eq? (next-token) 'rparen)
|
|
(begin (consume-token!) (list2vector ast1))
|
|
(parse-error '<vector> '(rparen))))))
|
|
(else (parse-error '<vector> '(vecstart)))))
|
|
|
|
(define (parse-data)
|
|
(case (next-token)
|
|
((id string
|
|
character
|
|
number
|
|
boolean
|
|
vecstart
|
|
lparen
|
|
quote
|
|
backquote
|
|
comma
|
|
splicing)
|
|
(let ((ast1 (parse-datum)))
|
|
(let ((ast2 (parse-data))) (cons ast1 ast2))))
|
|
((rparen period) (emptyList))
|
|
(else
|
|
(parse-error
|
|
'<data>
|
|
'(backquote
|
|
boolean
|
|
character
|
|
comma
|
|
id
|
|
lparen
|
|
number
|
|
period
|
|
quote
|
|
rparen
|
|
splicing
|
|
string
|
|
vecstart)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;
|
|
; End of LL(1) parser generated by ParseGen.
|
|
;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;
|
|
; Help predicates used by the lexical analyzer's state machine.
|
|
;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (isnotdoublequote? c) (not (char=? c #\")))
|
|
(define (isnotnewline? c) (not (char=? c #\newline)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;
|
|
; Lexical analyzer.
|
|
;
|
|
; This code is adapted from the quirk23 lexical analyzer written
|
|
; by Will Clinger for a compiler course.
|
|
;
|
|
; The scanner and parser were generated automatically and then
|
|
; printed using an R5RS Scheme pretty-printer, so they do not
|
|
; preserve case. In preparation for the case-sensitivity of
|
|
; R6RS Scheme, several identifiers and constants have been
|
|
; lower-cased in the hand-written code to match the generated
|
|
; code.
|
|
;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
; next-token and consume-token! are called by the parser.
|
|
|
|
; Returns the current token.
|
|
|
|
(define (next-token)
|
|
(if nextTokenIsReady
|
|
kindOfNextToken
|
|
(begin (set! string_accumulator_length 0)
|
|
(scanner0))))
|
|
|
|
; Consumes the current token.
|
|
|
|
(define (consume-token!)
|
|
(set! nextTokenIsReady #f))
|
|
|
|
; Called by the lexical analyzer's state machine,
|
|
; hence the unfortunate lower case.
|
|
|
|
(define (scannererror msg)
|
|
(define msgtxt
|
|
(cond ((= msg errLongToken)
|
|
"Amazingly long token")
|
|
((= msg errincompletetoken)
|
|
"in line ")
|
|
((= msg errLexGenBug)
|
|
"Bug in lexical analyzer (generated)")
|
|
(else "Bug in lexical analyzer")))
|
|
(fatal-error (string-append "Lexical Error: " msgtxt) lineNumber)
|
|
(set! nextTokenIsReady #f)
|
|
(set! nextCharacterIsReady #f)
|
|
(next-token))
|
|
|
|
; Accepts a token of the given kind, returning that kind.
|
|
;
|
|
; For some kinds of tokens, a value for the token must also be
|
|
; recorded in tokenValue.
|
|
|
|
(define (accept t)
|
|
(if (memq t '(boolean character id number string))
|
|
(set! tokenValue
|
|
(substring string_accumulator 0 string_accumulator_length)))
|
|
(set! kindOfNextToken t)
|
|
(set! nextTokenIsReady #t)
|
|
t)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;
|
|
; Character i/o, so to speak.
|
|
; Uses the input-string as input.
|
|
;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
; Returns the current character from the input.
|
|
|
|
(define (scanchar)
|
|
(if nextCharacterIsReady
|
|
nextCharacter
|
|
(begin (if (< input-index input-length)
|
|
(begin (set! nextCharacter
|
|
(string-ref input-string input-index))
|
|
(set! input-index (+ input-index 1)))
|
|
(set! nextCharacter eof))
|
|
(set! nextCharacterIsReady #t)
|
|
; For debugging, change #f to #t below.
|
|
(if #f
|
|
(write-char nextCharacter))
|
|
(scanchar))))
|
|
|
|
; Consumes the current character, and returns the next.
|
|
|
|
(define (consumechar)
|
|
(if (not nextCharacterIsReady)
|
|
(scanchar))
|
|
(if (< string_accumulator_length max_token_size)
|
|
(begin (set! nextCharacterIsReady #f)
|
|
(if (char=? nextCharacter #\newline)
|
|
(set! lineNumber (+ lineNumber 1)))
|
|
(string-set! string_accumulator
|
|
string_accumulator_length
|
|
nextCharacter)
|
|
(set! string_accumulator_length
|
|
(+ string_accumulator_length 1)))
|
|
(scannererror errLongToken)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;
|
|
; Action procedures called by the parser.
|
|
;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (emptyList) '())
|
|
|
|
(define (identity x) x)
|
|
|
|
(define (list2vector vals) (list->vector vals))
|
|
|
|
(define (makeBool)
|
|
(string=? tokenValue "#t"))
|
|
|
|
(define (makeChar)
|
|
(string-ref tokenValue 0))
|
|
|
|
(define (makeNum)
|
|
(string->number tokenValue))
|
|
|
|
(define (makeString)
|
|
; Must strip off outer double quotes.
|
|
; Ought to process escape characters also, but we won't.
|
|
(substring tokenValue 1 (- (string-length tokenValue) 1)))
|
|
|
|
(define (makeSym)
|
|
(string->symbol tokenValue))
|
|
|
|
; Like append, but allows the last argument to be a non-list.
|
|
|
|
(define (pseudoAppend vals terminus)
|
|
(if (null? vals)
|
|
terminus
|
|
(cons (car vals)
|
|
(pseudoAppend (cdr vals) terminus))))
|
|
|
|
(define (symBackquote) 'quasiquote)
|
|
(define (symQuote) 'quote)
|
|
(define (symSplicing) 'unquote-splicing)
|
|
(define (symUnquote) 'unquote)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;
|
|
; Error procedure called by the parser.
|
|
; As a hack, this error procedure recovers from end-of-file.
|
|
;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (parse-error nonterminal expected-terminals)
|
|
(if (eq? 'eof (next-token))
|
|
'eof
|
|
(begin
|
|
(display "Syntax error in line ")
|
|
(display lineNumber)
|
|
(display " while parsing a ")
|
|
(write nonterminal)
|
|
(newline)
|
|
(display " Encountered a ")
|
|
(display (next-token))
|
|
(display " while expecting something in")
|
|
(newline)
|
|
(display " ")
|
|
(write expected-terminals)
|
|
(newline)
|
|
(fatal-error "Syntax error"))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;
|
|
; Parses repeatedly, returning the last <datum> parsed.
|
|
;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(do ((x (parse-datum) (parse-datum))
|
|
(y 'eof x))
|
|
((eq? x 'eof)
|
|
y))))
|
|
|
|
(define (main . args)
|
|
(parsing-benchmark parsing-iters "../../src/test.sch"))
|