You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
42 lines
1.6 KiB
Scheme
42 lines
1.6 KiB
Scheme
(module actions mzscheme
|
|
|
|
(provide (all-defined))
|
|
|
|
;; wrap-action: (syntax-object or #f) symbol syntax-object syntax-object -> syntax-object
|
|
(define (wrap-action action result-name ctxt loc)
|
|
(if action
|
|
(let ((parms (datum->syntax-object
|
|
action
|
|
`(start-pos end-pos ,result-name return-without-pos input-port))))
|
|
(datum->syntax-object ctxt
|
|
`(lambda ,parms ,action)
|
|
loc))
|
|
(datum->syntax-object ctxt 'void loc)))
|
|
|
|
|
|
;; get-special-action: (syntax-object list) symbol 'a -> syntax-object or 'a
|
|
;; Returns the first action from a rule of the form ((which-special) action)
|
|
(define (get-special-action rules which-special none)
|
|
(cond
|
|
((null? rules) none)
|
|
(else
|
|
(syntax-case (car rules) ()
|
|
(((special) act)
|
|
(eq? (syntax-e (syntax special)) which-special)
|
|
(syntax act))
|
|
(_ (get-special-action (cdr rules) which-special none))))))
|
|
|
|
;; filter-out-specials: (syntax-object list) (symbol list) -> (syntax-object list)
|
|
;; Returns a list missing all the rules of the form ((special) action)
|
|
;; where special is a symbol in which specials.
|
|
(define (filter-out-specials rules which-specials)
|
|
(cond
|
|
((null? rules) null)
|
|
(else
|
|
(syntax-case (car rules) ()
|
|
(((special) act)
|
|
(memq (syntax-e (syntax special)) which-specials)
|
|
(filter-out-specials (cdr rules) which-specials))
|
|
(_ (cons (car rules) (filter-out-specials (cdr rules) which-specials)))))))
|
|
|
|
) |