From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 8 Sep 2008 18:19:54 +0000 (+0000)
Subject: Add DISQUALIFY keyword.
X-Git-Tag: 20090517-FFI~174
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c71b335b330873d13a215f7f2463dcb4bebbee1b;p=mit-scheme.git

Add DISQUALIFY keyword.
---

diff --git a/v7/src/runtime/structure-parser.scm b/v7/src/runtime/structure-parser.scm
index 21e78f427..bad16206d 100644
--- a/v7/src/runtime/structure-parser.scm
+++ b/v7/src/runtime/structure-parser.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: structure-parser.scm,v 14.2 2008/09/08 04:44:45 cph Exp $
+$Id: structure-parser.scm,v 14.3 2008/09/08 18:19:54 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -429,6 +429,16 @@ USA.
 	    ,(make-win vals lose)
 	    (,lose))))))
 
+(define-pattern-compiler '(DISQUALIFY EXPRESSION FORM) 'ANY
+  (lambda (pattern context env)
+    ((get-context-method 'TRANSFORM-VALS context)
+     (compile-pattern (caddr pattern) context env)
+     (lambda (make-win vals lose)
+       `(IF (NOT ,(call-out (close-syntax (cadr pattern) env)
+			    vals))
+	    ,(make-win vals lose)
+	    (,lose))))))
+
 (define-pattern-compiler '(TRANSFORM EXPRESSION FORM) 'ANY
   (lambda (pattern context env)
     ((get-context-method 'TRANSFORM-VALS context)