125 lines
6.2 KiB
Scheme
125 lines
6.2 KiB
Scheme
;; This library is used by match.ss
|
|
|
|
;;!(function parse-quasi
|
|
;; (form (parse-quasi syn) -> syntax)
|
|
;; (contract syntax -> syntax))
|
|
;; This function parses a quasi pattern in to a regular pattern
|
|
;; and returns it. This function does not parse the quasi pattern
|
|
;; recursively in order to find nested quasi patterns. It only
|
|
;; parses the top quasi pattern.
|
|
(define parse-quasi
|
|
(lambda (stx)
|
|
(letrec
|
|
((q-error (opt-lambda (syn [msg ""])
|
|
(match:syntax-err
|
|
stx
|
|
(string-append
|
|
"syntax error in quasi-pattern: "
|
|
msg))))
|
|
(parse-q
|
|
(lambda (phrase)
|
|
;(write phrase)(newline)
|
|
(syntax-case phrase (quasiquote unquote unquote-splicing)
|
|
(p
|
|
(let ((pat (syntax-object->datum (syntax p))))
|
|
(or (string? pat)
|
|
(boolean? pat)
|
|
(char? pat)
|
|
(number? pat)
|
|
(dot-dot-k? pat)))
|
|
(syntax p))
|
|
(p
|
|
(stx-null? (syntax p))
|
|
(syntax/loc stx (list)))
|
|
(p
|
|
;; although it is not in the grammer for quasi patterns
|
|
;; it seems important to not allow unquote splicing to be
|
|
;; a symbol in this case `,@(a b c). In this unquote-splicing
|
|
;; is treated as a symbol and quoted to be matched.
|
|
;; this is probably not what the programmer intends so
|
|
;; it may be better to throw a syntax error
|
|
(identifier? (syntax p))
|
|
(syntax/loc stx 'p))
|
|
;; ((var p) ;; we shouldn't worry about this in quasi-quote
|
|
;; (identifier? (syntax p))
|
|
;; (syntax/loc phrase 'p))
|
|
(,p (syntax p))
|
|
(,@pat
|
|
(q-error (syntax ,@pat) "unquote-splicing not nested in list"))
|
|
((x . y)
|
|
(let* ((list-type 'list)
|
|
(result
|
|
(let loop
|
|
((l (syntax-e (syntax (x . y)))))
|
|
;(write l)(newline)
|
|
(cond ((null? l) '())
|
|
((and (stx-pair? (car l))
|
|
(equal? (car (syntax-object->datum (car l)))
|
|
'unquote-splicing))
|
|
(let ((first-car
|
|
(syntax-case (car l)
|
|
(unquote-splicing quasiquote)
|
|
(,@`p ;; have to parse forward here
|
|
(let ((pq (parse-q (syntax p))))
|
|
(if (stx-list? pq)
|
|
(cdr (syntax->list pq))
|
|
(q-error (syntax ,@`p)
|
|
"unquote-splicing not followed by list"))))
|
|
(,@p
|
|
(if (stx-list? (syntax p))
|
|
(cdr (syntax->list (syntax p)))
|
|
(begin ; (write (syntax-e (syntax p)))
|
|
(q-error (syntax ,@p)
|
|
"unquote-splicing not followed by list")))))))
|
|
(syntax-case (cdr l) (unquote unquote-splicing)
|
|
(,@p (q-error (syntax ,@p)
|
|
"unquote-splicing can not follow dot notation"))
|
|
(,p
|
|
(let ((res (parse-q (syntax ,p))))
|
|
(set! list-type 'list-rest)
|
|
`(,@first-car ,res)))
|
|
(p (or (stx-pair? (syntax p))
|
|
(stx-null? (syntax p)))
|
|
(append first-car
|
|
(loop (syntax-e (syntax p)))))
|
|
(p ;; must be an atom
|
|
(let ((res (parse-q (syntax p))))
|
|
(set! list-type 'list-rest)
|
|
`(,@first-car ,res))))))
|
|
(else
|
|
(syntax-case (cdr l) (unquote unquote-splicing)
|
|
(,@p (q-error (syntax p)
|
|
"unquote-splicing can not follow dot notation"))
|
|
(,p (begin
|
|
(set! list-type 'list-rest)
|
|
(list (parse-q (car l))
|
|
(parse-q (syntax ,p)))))
|
|
(p (or (stx-pair? (syntax p))
|
|
(stx-null? (syntax p)))
|
|
(cons (parse-q (car l))
|
|
(loop (syntax-e (syntax p)))))
|
|
(p ;; must be an atom
|
|
(begin
|
|
(set! list-type 'list-rest)
|
|
(list (parse-q (car l))
|
|
(parse-q (syntax p)))))))))))
|
|
(quasisyntax/loc stx (#,list-type #,@result))))
|
|
(p
|
|
(vector? (syntax-object->datum (syntax p)))
|
|
(quasisyntax/loc
|
|
stx
|
|
(vector #,@(cdr
|
|
(syntax-e
|
|
(parse-q
|
|
(quasisyntax/loc
|
|
stx
|
|
#,(vector->list (syntax-e (syntax p))))))))))
|
|
(p
|
|
(box? (syntax-object->datum (syntax p)))
|
|
(quasisyntax/loc
|
|
stx
|
|
(box #,(parse-q (unbox (syntax-e (syntax p)))))))
|
|
(p (q-error (syntax p)))))))
|
|
(parse-q stx))))
|
|
|