suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

macro stepper: reorg. lifting error checking

Browse Source 
svn: r12703
This commit is contained in:
Ryan Culpepper 2008-12-04 21:35:42 +00:00
parent 6dabd5cb31
commit c47cbb564a
1 changed files with 12 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/macro-debugger/model/reductions.ss
View File

@ -272,7 +272,7 @@
[#:pass1] [#:pass1]
[Expr ?form first] [Expr ?form first]
[#:do (when (pair? (available-lift-stxs)) [#:do (when (pair? (available-lift-stxs))
(error 'lift-deriv "available lifts left over"))] (lift-error 'lift-deriv "available lifts left over"))]
[#:let begin-stx (stx-car lifted-stx)] [#:let begin-stx (stx-car lifted-stx)]
[#:with-visible-form [#:with-visible-form
;; If no lifts visible, then don't show begin-wrapping ;; If no lifts visible, then don't show begin-wrapping
@ -299,7 +299,7 @@
[#:pass1] [#:pass1]
[Expr ?form first] [Expr ?form first]
[#:do (when (pair? (available-lift-stxs)) [#:do (when (pair? (available-lift-stxs))
(error 'lift/let-deriv "available lifts left over"))] (lift-error 'lift/let-deriv "available lifts left over"))]
[#:let visible-lifts (visible-lift-stxs)] [#:let visible-lifts (visible-lift-stxs)]
[#:with-visible-form [#:with-visible-form
[#:left-foot] [#:left-foot]
@ -388,7 +388,7 @@
[#:pass1] [#:pass1]
[Expr ?form inner] [Expr ?form inner]
[#:do (when (pair? (available-lift-stxs)) [#:do (when (pair? (available-lift-stxs))
(error 'local-expand/capture-lifts "available lifts left over"))] (lift-error 'local-expand/capture-lifts "available lifts left over"))]
[#:let visible-lifts (visible-lift-stxs)] [#:let visible-lifts (visible-lift-stxs)]
[#:with-visible-form [#:with-visible-form
[#:left-foot] [#:left-foot]
@ -402,7 +402,7 @@
[(struct local-lift (expr id)) [(struct local-lift (expr id))
;; FIXME: add action ;; FIXME: add action
(R [#:do (unless (pair? (available-lift-stxs)) (R [#:do (unless (pair? (available-lift-stxs))
(error 'local-lift "out of lifts!")) (lift-error 'local-lift "out of lifts!"))
(when (pair? (available-lift-stxs)) (when (pair? (available-lift-stxs))
(let ([lift-d (car (available-lift-stxs))] (let ([lift-d (car (available-lift-stxs))]
[lift-stx (car (available-lift-stxs))]) [lift-stx (car (available-lift-stxs))])
@ -576,7 +576,7 @@
[#:pass1] [#:pass1]
[Expr ?firstL head] [Expr ?firstL head]
[#:do (when (pair? (available-lift-stxs)) [#:do (when (pair? (available-lift-stxs))
(error 'mod:lift "available lifts left over"))] (lift-error 'mod:lift "available lifts left over"))]
[#:let visible-lifts (visible-lift-stxs)] [#:let visible-lifts (visible-lift-stxs)]
[#:pattern ?forms] [#:pattern ?forms]
[#:pass2] [#:pass2]
@ -602,3 +602,10 @@
(R [#:pattern (?firstC . ?rest)] (R [#:pattern (?firstC . ?rest)]
[Expr ?firstC head] [Expr ?firstC head]
[ModulePass ?rest rest])])) [ModulePass ?rest rest])]))
;; lift-error
(define (lift-error sym . args)
(apply fprintf (current-error-port) args)
(when #t
(apply error sym args)))