|
|
@ -53,42 +53,43 @@
|
|
|
|
(if tokens
|
|
|
|
(if tokens
|
|
|
|
(raise-syntax-error #f "Multiple tokens declarations" stx)
|
|
|
|
(raise-syntax-error #f "Multiple tokens declarations" stx)
|
|
|
|
(set! tokens arg)))
|
|
|
|
(set! tokens arg)))
|
|
|
|
((start symbol)
|
|
|
|
((start symbol ...)
|
|
|
|
(cond
|
|
|
|
(let ((symbols (syntax->list (syntax (symbol ...)))))
|
|
|
|
((not (identifier? (syntax symbol)))
|
|
|
|
(for-each
|
|
|
|
(raise-syntax-error
|
|
|
|
(lambda (sym)
|
|
|
|
'parser-start
|
|
|
|
(unless (identifier? sym)
|
|
|
|
"Start non-terminal must be a symbol"
|
|
|
|
(raise-syntax-error 'parser-start
|
|
|
|
(syntax symbol)))
|
|
|
|
"Start symbol must be a symbol"
|
|
|
|
(start
|
|
|
|
sym)))
|
|
|
|
(raise-syntax-error #f "Multiple start declarations" stx))
|
|
|
|
symbols)
|
|
|
|
(else
|
|
|
|
(when start
|
|
|
|
(set! start (syntax symbol)))))
|
|
|
|
(raise-syntax-error #f "Multiple start declarations" stx))
|
|
|
|
|
|
|
|
(when (null? symbols)
|
|
|
|
|
|
|
|
(raise-syntax-error 'parser-start
|
|
|
|
|
|
|
|
"Missing start symbol"
|
|
|
|
|
|
|
|
stx))
|
|
|
|
|
|
|
|
(set! start symbols)))
|
|
|
|
((end symbols ...)
|
|
|
|
((end symbols ...)
|
|
|
|
(begin
|
|
|
|
(let ((symbols (syntax->list (syntax (symbols ...)))))
|
|
|
|
(for-each
|
|
|
|
(for-each
|
|
|
|
(lambda (sym)
|
|
|
|
(lambda (sym)
|
|
|
|
(if (not (identifier? sym))
|
|
|
|
(unless (identifier? sym)
|
|
|
|
(raise-syntax-error
|
|
|
|
(raise-syntax-error 'parser-end
|
|
|
|
'parser-end
|
|
|
|
"End token must be a symbol"
|
|
|
|
"End token must be a symbol"
|
|
|
|
sym)))
|
|
|
|
sym)))
|
|
|
|
symbols)
|
|
|
|
(syntax->list (syntax (symbols ...))))
|
|
|
|
(let ((d (duplicate-list? (map syntax-object->datum symbols))))
|
|
|
|
(let ((d (duplicate-list? (syntax-object->datum
|
|
|
|
(when d
|
|
|
|
(syntax (symbols ...))))))
|
|
|
|
(raise-syntax-error 'parser-end
|
|
|
|
(if d
|
|
|
|
(format "Duplicate end token definition for ~a" d)
|
|
|
|
(raise-syntax-error
|
|
|
|
arg))
|
|
|
|
'parser-end
|
|
|
|
(when (null? symbols)
|
|
|
|
(format "Duplicate end token definition for ~a" d)
|
|
|
|
(raise-syntax-error 'parser-end
|
|
|
|
arg)))
|
|
|
|
"end declaration must contain at least 1 token"
|
|
|
|
(if (= 0 (length (syntax->list (syntax (symbols ...)))))
|
|
|
|
arg))
|
|
|
|
(raise-syntax-error
|
|
|
|
(when end
|
|
|
|
'parser-end
|
|
|
|
|
|
|
|
"end declaration must contain at least 1 token"
|
|
|
|
|
|
|
|
arg))
|
|
|
|
|
|
|
|
(if end
|
|
|
|
|
|
|
|
(raise-syntax-error #f "Multiple end declarations" stx))
|
|
|
|
(raise-syntax-error #f "Multiple end declarations" stx))
|
|
|
|
(set! end (syntax->list (syntax (symbols ...))))))
|
|
|
|
(set! end symbols))))
|
|
|
|
((precs decls ...)
|
|
|
|
((precs decls ...)
|
|
|
|
(if precs
|
|
|
|
(if precs
|
|
|
|
(raise-syntax-error #f "Multiple precs declarations" stx)
|
|
|
|
(raise-syntax-error #f "Multiple precs declarations" stx)
|
|
|
@ -100,26 +101,25 @@
|
|
|
|
((yacc-output filename)
|
|
|
|
((yacc-output filename)
|
|
|
|
(cond
|
|
|
|
(cond
|
|
|
|
((not (string? (syntax-object->datum (syntax filename))))
|
|
|
|
((not (string? (syntax-object->datum (syntax filename))))
|
|
|
|
(raise-syntax-error
|
|
|
|
(raise-syntax-error 'parser-yacc-output
|
|
|
|
'parser-yacc-output
|
|
|
|
"Yacc-output filename must be a string"
|
|
|
|
"Yacc-output filename must be a string"
|
|
|
|
(syntax filename)))
|
|
|
|
(syntax filename)))
|
|
|
|
|
|
|
|
(yacc-output
|
|
|
|
(yacc-output
|
|
|
|
(raise-syntax-error #f "Multiple yacc-output declarations" stx))
|
|
|
|
(raise-syntax-error #f "Multiple yacc-output declarations" stx))
|
|
|
|
(else
|
|
|
|
(else
|
|
|
|
(set! yacc-output (syntax-object->datum (syntax filename))))))
|
|
|
|
(set! yacc-output (syntax-object->datum (syntax filename))))))
|
|
|
|
(_ (raise-syntax-error 'parser-args "argument must match (debug filename), (error expression), (tokens def ...), (start non-term), (end tokens ...), (precs decls ...), or (grammar prods ...)" arg))))
|
|
|
|
(_ (raise-syntax-error 'parser-args "argument must match (debug filename), (error expression), (tokens def ...), (start non-term), (end tokens ...), (precs decls ...), or (grammar prods ...)" arg))))
|
|
|
|
(syntax->list (syntax (args ...))))
|
|
|
|
(syntax->list (syntax (args ...))))
|
|
|
|
(if (not tokens)
|
|
|
|
(unless tokens
|
|
|
|
(raise-syntax-error #f "missing tokens declaration" stx))
|
|
|
|
(raise-syntax-error #f "missing tokens declaration" stx))
|
|
|
|
(if (not error)
|
|
|
|
(unless error
|
|
|
|
(raise-syntax-error #f "missing error declaration" stx))
|
|
|
|
(raise-syntax-error #f "missing error declaration" stx))
|
|
|
|
(if (not grammar)
|
|
|
|
(unless grammar
|
|
|
|
(raise-syntax-error #f "missing grammar declaration" stx))
|
|
|
|
(raise-syntax-error #f "missing grammar declaration" stx))
|
|
|
|
(if (not end)
|
|
|
|
(unless end
|
|
|
|
(raise-syntax-error #f "missing end declaration" stx))
|
|
|
|
(raise-syntax-error #f "missing end declaration" stx))
|
|
|
|
(if (not start)
|
|
|
|
(unless start
|
|
|
|
(raise-syntax-error #f "missing start declaration" stx))
|
|
|
|
(raise-syntax-error #f "missing start declaration" stx))
|
|
|
|
(let-values (((table term-sym->index actions check-syntax-fix)
|
|
|
|
(let-values (((table term-sym->index actions check-syntax-fix)
|
|
|
|
(build-parser (if debug debug "")
|
|
|
|
(build-parser (if debug debug "")
|
|
|
|
src-pos
|
|
|
|
src-pos
|
|
|
@ -130,23 +130,23 @@
|
|
|
|
precs
|
|
|
|
precs
|
|
|
|
grammar
|
|
|
|
grammar
|
|
|
|
stx)))
|
|
|
|
stx)))
|
|
|
|
(if (and yacc-output (not (string=? yacc-output "")))
|
|
|
|
(when (and yacc-output (not (string=? yacc-output "")))
|
|
|
|
(with-handlers [(exn:i/o:filesystem?
|
|
|
|
(with-handlers [(exn:i/o:filesystem?
|
|
|
|
(lambda (e)
|
|
|
|
(lambda (e)
|
|
|
|
(fprintf
|
|
|
|
(fprintf
|
|
|
|
(current-error-port)
|
|
|
|
(current-error-port)
|
|
|
|
"Cannot write yacc-output to file \"~a\". ~a~n"
|
|
|
|
"Cannot write yacc-output to file \"~a\". ~a~n"
|
|
|
|
(exn:i/o:filesystem-pathname e)
|
|
|
|
(exn:i/o:filesystem-pathname e)
|
|
|
|
(exn:i/o:filesystem-detail e))))]
|
|
|
|
(exn:i/o:filesystem-detail e))))]
|
|
|
|
(call-with-output-file yacc-output
|
|
|
|
(call-with-output-file yacc-output
|
|
|
|
(lambda (port)
|
|
|
|
(lambda (port)
|
|
|
|
(display-yacc (syntax-object->datum grammar)
|
|
|
|
(display-yacc (syntax-object->datum grammar)
|
|
|
|
tokens
|
|
|
|
tokens
|
|
|
|
(syntax-object->datum start)
|
|
|
|
(syntax-object->datum start)
|
|
|
|
(if precs
|
|
|
|
(if precs
|
|
|
|
(syntax-object->datum precs)
|
|
|
|
(syntax-object->datum precs)
|
|
|
|
#f)
|
|
|
|
#f)
|
|
|
|
port)))))
|
|
|
|
port)))))
|
|
|
|
(with-syntax ((check-syntax-fix check-syntax-fix)
|
|
|
|
(with-syntax ((check-syntax-fix check-syntax-fix)
|
|
|
|
(err error)
|
|
|
|
(err error)
|
|
|
|
(ends end)
|
|
|
|
(ends end)
|
|
|
@ -160,10 +160,9 @@
|
|
|
|
check-syntax-fix
|
|
|
|
check-syntax-fix
|
|
|
|
(parser-body debug err (quote ends) table term-sym->index actions src-pos)))))))
|
|
|
|
(parser-body debug err (quote ends) table term-sym->index actions src-pos)))))))
|
|
|
|
(_
|
|
|
|
(_
|
|
|
|
(raise-syntax-error
|
|
|
|
(raise-syntax-error #f
|
|
|
|
#f
|
|
|
|
"parser must have the form (parser args ...)"
|
|
|
|
"parser must have the form (parser args ...)"
|
|
|
|
stx))))
|
|
|
|
stx))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define (reduce-stack stack num ret-vals src-pos)
|
|
|
|
(define (reduce-stack stack num ret-vals src-pos)
|
|
|
|
(cond
|
|
|
|
(cond
|
|
|
@ -181,7 +180,7 @@
|
|
|
|
|
|
|
|
|
|
|
|
(define-struct stack-frame (state value start-pos end-pos) (make-inspector))
|
|
|
|
(define-struct stack-frame (state value start-pos end-pos) (make-inspector))
|
|
|
|
|
|
|
|
|
|
|
|
(define empty-stack (list (make-stack-frame 0 #f #f #f)))
|
|
|
|
(define (make-empty-stack i) (list (make-stack-frame i #f #f #f)))
|
|
|
|
|
|
|
|
|
|
|
|
(define (false-thunk) #f)
|
|
|
|
(define (false-thunk) #f)
|
|
|
|
|
|
|
|
|
|
|
@ -285,59 +284,62 @@
|
|
|
|
(err #f (token-name tok) (token-value tok) (cadr ip) (caddr ip))
|
|
|
|
(err #f (token-name tok) (token-value tok) (cadr ip) (caddr ip))
|
|
|
|
(err #f (token-name tok) (token-value tok)))
|
|
|
|
(err #f (token-name tok) (token-value tok)))
|
|
|
|
(raise-read-error (format "parser: got token of unknown type ~a" (token-name tok))
|
|
|
|
(raise-read-error (format "parser: got token of unknown type ~a" (token-name tok))
|
|
|
|
#f #f #f #f #f)))))))
|
|
|
|
#f #f #f #f #f))))))
|
|
|
|
(lambda (get-token)
|
|
|
|
(make-parser
|
|
|
|
(let parsing-loop ((stack empty-stack)
|
|
|
|
(lambda (start-number)
|
|
|
|
(ip (get-token)))
|
|
|
|
(lambda (get-token)
|
|
|
|
(let* ((tok (input->token ip))
|
|
|
|
(let parsing-loop ((stack (make-empty-stack start-number))
|
|
|
|
(action (find-action stack tok ip)))
|
|
|
|
(ip (get-token)))
|
|
|
|
(cond
|
|
|
|
(let* ((tok (input->token ip))
|
|
|
|
((shift? action)
|
|
|
|
(action (find-action stack tok ip)))
|
|
|
|
;; (printf "shift:~a~n" (shift-state action))
|
|
|
|
(cond
|
|
|
|
(let ((val (token-value tok)))
|
|
|
|
((shift? action)
|
|
|
|
(parsing-loop (cons (if src-pos
|
|
|
|
;; (printf "shift:~a~n" (shift-state action))
|
|
|
|
(make-stack-frame (shift-state action)
|
|
|
|
(let ((val (token-value tok)))
|
|
|
|
val
|
|
|
|
(parsing-loop (cons (if src-pos
|
|
|
|
(cadr ip)
|
|
|
|
(make-stack-frame (shift-state action)
|
|
|
|
(caddr ip))
|
|
|
|
val
|
|
|
|
(make-stack-frame (shift-state action)
|
|
|
|
(cadr ip)
|
|
|
|
val
|
|
|
|
(caddr ip))
|
|
|
|
#f
|
|
|
|
(make-stack-frame (shift-state action)
|
|
|
|
#f))
|
|
|
|
val
|
|
|
|
stack)
|
|
|
|
#f
|
|
|
|
(get-token))))
|
|
|
|
#f))
|
|
|
|
((reduce? action)
|
|
|
|
stack)
|
|
|
|
;; (printf "reduce:~a~n" (reduce-prod-num action))
|
|
|
|
(get-token))))
|
|
|
|
(let-values (((new-stack args)
|
|
|
|
((reduce? action)
|
|
|
|
(reduce-stack stack
|
|
|
|
;; (printf "reduce:~a~n" (reduce-prod-num action))
|
|
|
|
(reduce-rhs-length action)
|
|
|
|
(let-values (((new-stack args)
|
|
|
|
null
|
|
|
|
(reduce-stack stack
|
|
|
|
src-pos)))
|
|
|
|
(reduce-rhs-length action)
|
|
|
|
(let* ((A (reduce-lhs-num action))
|
|
|
|
null
|
|
|
|
(goto (array2d-ref table (stack-frame-state (car new-stack)) A)))
|
|
|
|
src-pos)))
|
|
|
|
(parsing-loop (cons
|
|
|
|
(let* ((A (reduce-lhs-num action))
|
|
|
|
(if src-pos
|
|
|
|
(goto (array2d-ref table (stack-frame-state (car new-stack)) A)))
|
|
|
|
(make-stack-frame goto
|
|
|
|
(parsing-loop
|
|
|
|
(apply (vector-ref actions (reduce-prod-num action)) args)
|
|
|
|
(cons
|
|
|
|
(if (null? args) (cadr ip) (cadr args))
|
|
|
|
(if src-pos
|
|
|
|
(if (null? args)
|
|
|
|
(make-stack-frame
|
|
|
|
(caddr ip)
|
|
|
|
goto
|
|
|
|
(list-ref args (- (* (reduce-rhs-length action) 3) 1))))
|
|
|
|
(apply (vector-ref actions (reduce-prod-num action)) args)
|
|
|
|
(make-stack-frame goto
|
|
|
|
(if (null? args) (cadr ip) (cadr args))
|
|
|
|
(apply (vector-ref actions (reduce-prod-num action)) args)
|
|
|
|
(if (null? args)
|
|
|
|
#f
|
|
|
|
(caddr ip)
|
|
|
|
#f))
|
|
|
|
(list-ref args (- (* (reduce-rhs-length action) 3) 1))))
|
|
|
|
new-stack)
|
|
|
|
(make-stack-frame
|
|
|
|
ip))))
|
|
|
|
goto
|
|
|
|
((accept? action)
|
|
|
|
(apply (vector-ref actions (reduce-prod-num action)) args)
|
|
|
|
;; (printf "accept~n")
|
|
|
|
#f
|
|
|
|
(stack-frame-value (car stack)))
|
|
|
|
#f))
|
|
|
|
(else
|
|
|
|
new-stack)
|
|
|
|
(if src-pos
|
|
|
|
ip))))
|
|
|
|
(err #t (token-name tok) (token-value tok) (cadr ip) (caddr ip))
|
|
|
|
((accept? action)
|
|
|
|
(err #t (token-name tok) (token-value tok)))
|
|
|
|
;; (printf "accept~n")
|
|
|
|
(parsing-loop (fix-error stack tok ip get-token) (get-token)))))))))
|
|
|
|
(stack-frame-value (car stack)))
|
|
|
|
|
|
|
|
(else
|
|
|
|
|
|
|
|
(if src-pos
|
|
|
|
|
|
|
|
(err #t (token-name tok) (token-value tok) (cadr ip) (caddr ip))
|
|
|
|
|
|
|
|
(err #t (token-name tok) (token-value tok)))
|
|
|
|
|
|
|
|
(parsing-loop (fix-error stack tok ip get-token) (get-token))))))))))
|
|
|
|
|
|
|
|
(make-parser 0)))
|
|
|
|
)
|
|
|
|
)
|