umatch fix

parent daa0457c
......@@ -464,6 +464,11 @@
((_ fr code)
(mk-failure0 fr (lambda () code)))))
(define-syntax mk-failure-
(syntax-rules ()
((_ fr code)
(lambda () (code)))))
(define-syntax umatch***+
(syntax-rules (+)
((_ a b c (#f . l))
......@@ -471,11 +476,22 @@
((_ (code) () () (s n t _ _))
(umatch0 s (#:args)
((arguments) (-> t (mk-failure s))
((arguments) (-> t (mk-failure- s))
code)
(_ (error (format #f "umatch ~a did not match" n)))))
((_ (code ...) () () (s n t _ _))
((_ (codes ... code) () () (s n t _ _))
(let ((s (gp-newframe s)))
(umatch0 s (#:args)
((arguments) (-> t (mk-failure s))
codes)
...
((arguments) (-> t (mk-failure- s))
code)
(_ (error (format #f "umatch ~a did not match" n))))))
#;((_ (code ...) () () (s n t _ _))
(let ((s (gp-newframe s)))
(umatch0 s (#:args)
((arguments) (-> t (mk-failure s))
......@@ -486,15 +502,17 @@
((_ (code) ((a ...)) arg (s n t #t +))
(umatch0 s (#:args . arg)
((arguments (++ ++ a) ...)
(-> t (mk-failure s))
(-> t (mk-failure- s))
code)
(_ (error (format #f "umatch ~a did not match" n)))))
((_ (code) ((as ...) ... (a ...)) arg (s n t #t +))
(let ((sold s))
(umatch0 s (#:args . arg)
((arguments (++ ++ a) ...)
((arguments (++ ++ a) ...) (-> t (mk-failure- s))
(gp-clear-frame)
(let ((s sold)) code))
(_ (error (format #f "umatch ~a did not match" n))))))
......@@ -508,6 +526,59 @@
codes)
...
((arguments (++ ++ a) ...) (-> t (mk-failure- s))
(gp-clear-frame)
(let ((s sold)) code))
(_ (error (format #f "umatch ~a did not match" n))))))
#;((_ (codes ... code) ((as ...) ... (a ...)) arg (s n t #t +))
(let ((sold s)
(s (gp-newframe s)))
(umatch0 s (#:args . arg)
((arguments (++ ++ as) ...)
(-> t (mk-failure s))
codes)
...
((arguments (++ ++ a) ...)
(gp-clear-frame)
(let ((s sold)) code))
(_ (error (format #f "umatch ~a did not match" n))))))
((_ (code) ((as ...) ... (a ...)) arg (s n t #t +))
(let ((sold s)
(s (gp-newframe s)))
(umatch0 s (#:args . arg)
((arguments (++ ++ a) ...)
(-> t (mk-failure- s))
(gp-clear-frame)
(let ((s sold)) code))
(_ (error (format #f "umatch ~a did not match" n))))))
((_ (codes ... code) ((as ...) ... (a ...)) arg (s n t #t +))
(let ((sold s)
(s (gp-newframe s)))
(umatch0 s (#:args . arg)
((arguments (++ ++ as) ...)
(-> t (mk-failure s))
code)
...
((arguments (++ ++ a) ...)
(-> t (mk-failure- s))
(gp-clear-frame)
(let ((s sold)) code))
(_ (error (format #f "umatch ~a did not match" n))))))
#;((_ (codes ... code) ((as ...) ... (a ...)) arg (s n t #t +))
(let ((sold s)
(s (gp-newframe s)))
(umatch0 s (#:args . arg)
((arguments (++ ++ as) ...)
(-> t (mk-failure s))
code)
...
((arguments (++ ++ a) ...)
(gp-clear-frame)
(let ((s sold)) code))
......@@ -516,12 +587,12 @@
((_ (code) ((a ...)) arg (s n t r m))
(umatch0 s (#:args . arg)
((arguments (m m a) ...)
(-> t (mk-failure s))
code)
(_ (error (format #f "umatch ~a did not match" n)))))
((_ (code) ((as ...) ... (a ...)) arg (s n t r m))
(let ((sold s))
(let ((sold s)
(s (gp-newframe s)))
(umatch0 s (#:args . arg)
((arguments (m m a) ...)
(let ((s sold))
......@@ -541,7 +612,22 @@
(let ((s sold))
(gp-clear-frame)
code))
(_ (error (format #f "umatch ~a did not match" n))))))))
(_ (error (format #f "umatch ~a did not match" n))))))
#;((_ (codes ... code) ((as ...) ... (a ...)) arg (s n t r m))
(let ((sold s)
(s (gp-newframe s)))
(umatch0 s (#:args . arg)
((arguments (m m as) ...)
(-> t (mk-failure s))
codes)
...
((arguments (m m a) ...)
(let ((s sold))
(gp-clear-frame)
code))
(_ (error (format #f "umatch ~a did not match" n))))))))
(define gp-restore-state-raw (@ (logic guile-log code-load) gp-restore-state))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment