From 6f26a0ffebe3bf110198bee8155411503a8eb14a Mon Sep 17 00:00:00 2001
From: Jon Rafkind <rafkind@racket-lang.org>
Date: Mon, 25 Jan 2010 23:21:26 +0000
Subject: [PATCH] add trigraph expression

svn: r17831
---
 collects/honu/main.ss                      |  2 +
 collects/honu/private/honu-typed-scheme.ss | 49 ++++++++--------------
 2 files changed, 20 insertions(+), 31 deletions(-)

diff --git a/collects/honu/main.ss b/collects/honu/main.ss
index 276d7b890a..47b363b786 100644
--- a/collects/honu/main.ss
+++ b/collects/honu/main.ss
@@ -10,6 +10,8 @@
                      (honu-* *)
                      (honu-/ /)
                      (honu-- -)
+                     (honu-? ?)
+                     (honu-: :)
                      )
          #%datum
          true
diff --git a/collects/honu/private/honu-typed-scheme.ss b/collects/honu/private/honu-typed-scheme.ss
index 2e76837023..243f083da2 100644
--- a/collects/honu/private/honu-typed-scheme.ss
+++ b/collects/honu/private/honu-typed-scheme.ss
@@ -32,7 +32,8 @@
 (define-literal honu-+ honu-* honu-/ honu-- honu-|| honu-%
                 honu-= honu-+= honu--= honu-*= honu-/= honu-%=
                 honu-&= honu-^= honu-\|= honu-<<= honu->>= honu->>>=
-                honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->=)
+                honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->=
+                honu-? honu-:)
 
 ;; (define-syntax (\; stx) (raise-syntax-error '\; "out of context" stx))
 
@@ -368,7 +369,7 @@ x(2)
                          [pattern f])
 
     (define-splicing-syntax-class call
-                         [pattern (~seq e:expr (#%parens arg:expression-1))
+                         [pattern (~seq e:expr (#%parens arg:trigraph))
                                   #:with call #'(e arg.result)])
     (define-splicing-syntax-class expression-last
                          [pattern (~seq call:call) #:with result #'call.call]
@@ -390,18 +391,6 @@ x(2)
                         [else
                          #'left.result])))))
 
-    #;
-    (define-syntax-rule (define-infix-operator name next [operator reducer] ...)
-      (define-splicing-syntax-class name
-                                    #:literals (operator ...)
-                                    [pattern (~seq (~var left next) operator (~var right name))
-                                             #:with result (reducer #'left.result #'right.result)]
-                                    ...
-                                    [pattern (~seq (~var exp next))
-                                             #:with result #'exp.result]
-                                    ))
-
-    ;; TODO: maybe just have a precedence macro that creates all these constructs
     ;;   (infix-operators ([honu-* ...]
     ;;                     [honu-- ...])
     ;;                    ([honu-+ ...]
@@ -430,23 +419,6 @@ x(2)
              #'(begin
                  result ...)))]))
 
-    #;
-    (infix-operators expression-1 expression-last
-                       ([honu-+ (syntax-lambda (left right)
-                                    #'(+ left right))]
-                        [honu-- (syntax-lambda (left right)
-                                               #'(- left right))])
-                       ([honu-* (syntax-lambda (left right)
-                                               #'(* left right))]
-                        [honu-/ (syntax-lambda (left right)
-                                               #'(/ left right))]))
-    
-
-    (define-syntax-class expression-top
-                         [pattern (e:expression-1 semicolon . rest)
-                                  #:with result #'e.result])
-
-
     ;; infix operators in the appropriate precedence level
     ;; things defined lower in the table have a higher precedence.
     ;; the first set of operators is `expression-1'
@@ -478,10 +450,25 @@ x(2)
          [honu-% (sl (left right) #'(modulo left right))]
          [honu-/ (sl (left right) #'(/ left right))])))
 
+    (define-splicing-syntax-class trigraph
+      #:literals (honu-? honu-:)
+      [pattern (~seq condition:expression-1 (~optional (~seq honu-? on-true:trigraph
+                                                             honu-: on-false:trigraph)))
+               #:with result
+               (cond [(attribute on-true)
+                      #'(if condition.result on-true.result on-false.result)]
+                     [else #'condition.result])])
+
+    (define-syntax-class expression-top
+                         #:literals (semicolon)
+      [pattern (e:trigraph semicolon . rest)
+               #:with result #'e.result])
+
     ;; (printf "~a\n" (syntax-class-parse function stx))
     (syntax-parse stx
       [function:function (values #'function.result #'function.rest)]
       [expr:expression-top (values #'expr.result #'expr.rest)]
+      #;
       [(x:number . rest) (values #'x #'rest)]
       ))
   (cond