From ac3581286f0c33b448e06104e2f762286b5928c7 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Wed, 29 Jul 2009 19:07:03 +0300
Subject: [PATCH] Ikarus now supports PLT's Scribble syntax! - The only thing
 unsupported is the transposition of punctuations,   e.g., @`foo{bar} =>
 `@foo{bar}.

---
 scheme/Makefile.am       |   1 +
 scheme/Makefile.in       |   1 +
 scheme/ikarus.reader.ss  | 390 ++++++++++++++++++++++++++++-
 scheme/last-revision     |   2 +-
 scheme/run-tests.ss      |   2 +-
 scheme/tests/scribble.ss | 522 +++++++++++++++++++++++++++++++++++++++
 6 files changed, 911 insertions(+), 7 deletions(-)
 create mode 100644 scheme/tests/scribble.ss

diff --git a/scheme/Makefile.am b/scheme/Makefile.am
index 5c7a63c..f88f745 100644
--- a/scheme/Makefile.am
+++ b/scheme/Makefile.am
@@ -69,6 +69,7 @@ EXTRA_DIST=ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt last-revision \
   tests/sorting.ss \
   tests/string-to-number.ss \
   tests/strings.ss \
+  tests/scribble.ss \
   tests/symbol-table.ss \
   tests/tests-1.1-req.scm \
   tests/tests-1.2-req.scm \
diff --git a/scheme/Makefile.in b/scheme/Makefile.in
index e0e16cb..517d6a8 100644
--- a/scheme/Makefile.in
+++ b/scheme/Makefile.in
@@ -224,6 +224,7 @@ EXTRA_DIST = ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt last-revision \
   tests/sorting.ss \
   tests/string-to-number.ss \
   tests/strings.ss \
+  tests/scribble.ss \
   tests/symbol-table.ss \
   tests/tests-1.1-req.scm \
   tests/tests-1.2-req.scm \
diff --git a/scheme/ikarus.reader.ss b/scheme/ikarus.reader.ss
index 2d7af63..594e924 100644
--- a/scheme/ikarus.reader.ss
+++ b/scheme/ikarus.reader.ss
@@ -25,7 +25,8 @@
     (ikarus system $fx)
     (ikarus system $pairs)
     (ikarus system $bytevectors)
-    (only (ikarus.io) input-port-byte-position)
+    (only (ikarus.io) input-port-byte-position
+          input-port-column-number)
     (except (ikarus) read-char read read-token comment-handler get-datum
       read-annotated read-script-annotated annotation?
       annotation-expression annotation-source annotation-stripped))
@@ -74,7 +75,7 @@
   (define delimiter?
     (lambda (c)
       (or (char-whitespace? c)
-          (memq c '(#\( #\) #\[ #\] #\" #\# #\; #\{ #\})))))
+          (memq c '(#\( #\) #\[ #\] #\" #\# #\; #\{ #\} #\|)))))
   (define digit?
     (lambda (c)
       (and ($char<= #\0 c) ($char<= c #\9))))
@@ -121,10 +122,10 @@
          [(char=? c #\\)
           (read-char p)
           (tokenize-backslash ls p)]
-         [(char=? c #\}) ls]
-         [else
+         [(eq? (port-mode p) 'r6rs-mode)
           (die/p p 'tokenize "invalid identifier syntax" 
-            (list->string (reverse (cons c ls))))]))))
+            (list->string (reverse (cons c ls))))]
+         [else ls]))))
   (define (tokenize-string ls p)
     (let ([c (read-char p)])
       (cond
@@ -781,6 +782,11 @@
             (string->symbol
               (list->string
                 (reverse (tokenize-backslash '() p)))))]
+        ;[($char= #\{ c) 'lbrace]
+        [($char= #\@ c) 
+         (when (eq? (port-mode p) 'r6rs-mode)
+           (die 'tokenize "@-expr syntax is invalid in #!r6rs mode"))
+         'at-expr]
         [else
          (die/p-1 p 'tokenize "invalid syntax" c)])))
 
@@ -1006,6 +1012,378 @@
                     "invalid value in a bytevector" a))
                 (read-bytevector p locs k (fxadd1 count) 
                   (cons a ls)))]))))
+    (define read-at-expr
+      (lambda (p locs k at-pos)
+        (define-struct nested (a a^))
+        (define-struct nested* (a* a*^))
+        (define (get-chars chars pos p a* a*^)
+          (if (null? chars)
+              (values a* a*^)
+              (let ([str (list->string chars)])
+                (let ([str^ (annotate-simple str pos p)])
+                  (values (cons str a*) (cons str^ a*^))))))
+        (define (return start-pos start-col c*** p)
+          (let ([indent 
+                 (apply min start-col
+                   (map
+                     (lambda (c**)
+                       (define (st00 c* c** n)
+                         (if (null? c*)
+                             (st0 c** n)
+                             (if (char=? (car c*) #\space)
+                                 (st00 (cdr c*) c** (+ n 1))
+                                 n)))
+                       (define (st0 c** n)
+                         (if (null? c**)
+                             start-col
+                             (let ([c* (car c**)])
+                               (if (or (nested? c*) (nested*? c*))
+                                   start-col
+                                   (st00 (car c*) (cdr c**) n)))))
+                       (st0 c** 0))
+                     (cdr c***)))])
+            (define (convert c*)
+              (if (or (nested? c*) (nested*? c*))
+                  c*
+                  (let ([str (list->string (car c*))])
+                    (let ([str^ (annotate-simple str (cdr c*) p)])
+                      (make-nested str str^)))))
+            (define (trim/convert c**)
+              (define (mk n pos)
+                (let ([str (make-string (- n indent) #\space)])
+                  (let ([str^ (annotate-simple str pos p)])
+                    (make-nested str str^))))
+              (define (s1 c* pos c** n)
+                (if (null? c*)
+                    (let ([c* (car c**)])
+                      (if (or (nested? c*) (nested*? c*))
+                          (cons (mk n pos) (map convert c**))
+                          (s1 c* pos (cdr c**) n)))
+                    (if (char=? (car c*) #\space)
+                        (s1 (cdr c*) pos c** (+ n 1))
+                        (cons* 
+                          (mk n pos)
+                          (map convert (cons (cons c* pos) c**))))))
+              (define (s00 c* pos c** n)
+                (if (null? c*)
+                    (s0 c** n)
+                    (if (char=? #\space (car c*))
+                        (if (< n indent)
+                            (s00 (cdr c*) pos c** (+ n 1))
+                            (s1 (cdr c*) pos c** (+ n 1)))
+                        (map convert (cons (cons c* pos) c**)))))
+              (define (s0 c** n)
+                (if (null? c**)
+                    '()
+                    (let ([c* (car c**)])
+                      (if (or (nested? c*) (nested*? c*))
+                          (map convert c**)
+                          (s00 (car c*) (cdr c*) (cdr c**) n)))))
+              (s0 c** 0))
+            (define (cons-initial c** c***)
+              (define (all-white? c**)
+                (andmap (lambda (c*) 
+                          (and (not (nested? c*))
+                               (not (nested*? c*))
+                               (andmap 
+                                 (lambda (c) (char=? c #\space))
+                                 (car c*))))
+                        c**))
+              (define (nl)
+                (let ([str "\n"])
+                  (list (make-nested str str))))
+              (define (S1 c*** n)
+                (if (null? c***)
+                    (make-list n (nl))
+                    (let ([c** (car c***)] [c*** (cdr c***)])
+                      (if (all-white? c**)
+                          (S1 c*** (+ n 1))
+                          (append
+                            (make-list n (nl))
+                            (cons (trim/convert c**)
+                                  (S2 c*** 0 0)))))))
+              (define (S2 c*** n m)
+                (if (null? c***)
+                    (make-list (+ n m) (nl))
+                    (let ([c** (car c***)] [c*** (cdr c***)])
+                      (if (all-white? c**)
+                          (S2 c*** (+ n 1) -1)
+                          (append
+                            (make-list (+ n 1) (nl))
+                            (cons (trim/convert c**)
+                                  (S2 c*** 0 0)))))))
+              (define (S0 c** c***)
+                (if (all-white? c**)
+                    (S1 c*** 0)
+                    (cons
+                      (map convert c**)
+                      (S2 c*** 0 0))))
+              (S0 c** c***))
+            (let ([c** (cons-initial (car c***) (cdr c***))])
+              (let ([n* (apply append c**)])
+                (define (extract p p* ls)
+                  (let f ([ls ls])
+                    (cond
+                      [(null? ls) '()]
+                      [(nested? (car ls)) (cons (p (car ls)) (f (cdr ls)))]
+                      [else (append (p* (car ls)) (f (cdr ls)))])))
+                (let ([c* (extract nested-a nested*-a* n*)]
+                      [c*^ (extract nested-a^ nested*-a*^ n*)])
+                  (values c* (annotate c* c*^ start-pos p) locs k))))))
+        (define (read-text p locs k pref*)
+          (let ([start-pos (port-position p)]
+                [start-col (input-port-column-number p)])
+            (let f ([c* '()] [pos start-pos]
+                    [c** '()] [c*** '()]
+                    [depth 0] [locs locs] [k k])
+              (define (match-prefix c* pref*)
+                (cond
+                  [(and (pair? c*) (pair? pref*))
+                   (and (char=? (car c*) (car pref*)) 
+                        (match-prefix (cdr c*) (cdr pref*)))]
+                  [else (and (null? pref*) c*)]))
+              (let ([c (read-char p)])
+                (cond
+                  [(eof-object? c)
+                   (die/p p 'read "end of file while reading @-expr text")]
+                  [(char=? c #\})
+                   (let g ([x* (cons #\} c*)] [p* pref*])
+                     (if (null? p*)
+                         (if (= depth 0)
+                             (let ([c** 
+                                    (reverse
+                                      (if (null? c*)
+                                          c**
+                                          (cons (cons (reverse c*) pos) c**)))])
+                               (let ([c*** (reverse (cons c** c***))])
+                                 (return start-pos start-col c*** p)))
+                             (f x* pos c** c*** (- depth 1) locs k))
+                         (let ([c (peek-char p)])
+                           (cond
+                             [(eof-object? c) 
+                              (die/p p 'read "invalid eof inside @-expression")]
+                             [(char=? c (rev-punc (car p*)))
+                              (read-char p)
+                              (g (cons c x*) (cdr p*))]
+                             [else
+                              (f x* pos c** c*** depth locs k)]))))]
+                  [(char=? c #\{)
+                   (f (cons c c*) pos c** c*** 
+                      (if (match-prefix c* pref*) (+ depth 1) depth)
+                      locs k)]
+                  [(char=? c #\newline)
+                   (f '()
+                      (port-position p)
+                      '()
+                      (cons (reverse 
+                              (if (null? c*)
+                                  c**
+                                  (cons (cons (reverse c*) pos) c**)))
+                            c***)
+                      depth locs k)]
+                  [(and (char=? c #\@) (match-prefix c* pref*)) =>
+                   (lambda (c*)
+                     (let ([c (peek-char p)])
+                       (cond
+                         [(eof-object? c) 
+                          (die/p p 'read "invalid eof inside nested @-expr")]
+                         [(char=? c #\") 
+                          (read-char p)
+                          (let ([c* (tokenize-string c* p)])
+                            (f c* pos c** c*** depth locs k))]
+                         [else
+                          (let-values ([(a* a*^ locs k)
+                                        (read-at-text-mode p locs k)])
+                            (f '()
+                               (port-position p)
+                               (cons (make-nested* a* a*^)
+                                 (if (null? c*)
+                                     c**
+                                     (cons (cons (reverse c*) pos) c**)))
+                               c*** depth locs k))])))]
+                  [else
+                   (f (cons c c*) pos c** c*** depth locs k)])))))
+        (define (read-brackets p locs k)
+          (let-values ([(a* a*^ locs k)
+                        (read-list p locs k 'rbrack 'rparen #t)])
+            (unless (list? a*) 
+              (die/ann a*^ 'read "not a proper list"))
+            (let ([c (peek-char p)])
+              (cond
+                [(eof-object? c) ;;; @<cmd>[...]
+                 (values a* a*^ locs k)]
+                [(char=? c #\{)
+                 (read-char p)
+                 (let-values ([(b* b*^ locs k)
+                               (read-text p locs k '())])
+                   (values (append a* b*)
+                           (append a*^ b*^)
+                           locs k))]
+                [(char=? c #\|) 
+                 (read-char p)
+                 (let-values ([(b* b*^ locs k)
+                               (read-at-bar p locs k #t)])
+                   (values (append a* b*) 
+                           (append a*^ b*^)
+                           locs k))]
+                [else (values a* a*^ locs k)]))))
+        (define puncs 
+          '([#\| . #\|]
+            [#\< . #\>]
+            [#\[ . #\]]
+            [#\( . #\)]
+            [#\! . #\!]
+            [#\- . #\-]))
+        (define (left-punc? c)
+          (and (assv c (cdr puncs)) #t))
+        (define (rev-punc c) (cdr (assv c puncs)))
+        (define (read-at-bar p locs k text-mode?)
+          (let ([c (peek-char p)])
+            (cond
+              [(eof-object? c)
+               (die/p p 'read "eof inside @|-expression")]
+              [(and (char=? c #\|) text-mode?) ;;; @||
+               (read-char p)
+               (values '() '() locs k)]
+              [(char=? c #\{) ;;; @|{
+               (read-char p)
+               (read-text p locs k '(#\|))]
+              [(left-punc? c) ;;; @|<({
+               (read-char p)
+               (let ([pos (port-position p)])
+                 (let f ([ls (list c)])
+                   (let ([c (peek-char p)])
+                     (cond
+                       [(eof-object? c) 
+                        (die/p p 'read "eof inside @|< mode")]
+                       [(left-punc? c)
+                        (read-char p)
+                        (f (cons c ls))]
+                       [(char=? c #\{)
+                        (read-char p)
+                        (read-text p locs k (append ls '(#\|)))]
+                       [else 
+                        (read-at-bar-others ls p locs k)]))))]
+              [text-mode? ;;; @|5 6 7|
+               (read-at-bar-datum p locs k)]
+              [else 
+               (die/p p 'read "invalid char in @| mode" c)])))
+        (define (read-at-bar-others ls p locs k)
+          (define (split ls)
+            (cond
+              [(null? ls) (values '() '())]
+              [(initial? (car ls)) 
+               (let-values ([(a d) (split (cdr ls))])
+                 (values (cons (car ls) a) d))]
+              [else 
+               (values '() ls)]))
+          (define (mksymbol ls)
+            (let ([s (string->symbol
+                       (list->string
+                         (reverse ls)))])
+              (values s s)))
+          (let-values ([(inits rest) (split ls)])
+            (let ([ls (tokenize-identifier inits p)])
+              (let-values ([(s s^) (mksymbol ls)])
+                (let g ([rest rest]
+                        [a* (list s)]
+                        [a*^ (list s^)]
+                        [locs locs]
+                        [k k])
+                  (if (null? rest)
+                      (let-values ([(b* b*^ locs k)
+                                    (read-at-bar-datum p locs k)])
+                        (values (append a* b*) (append a*^ b*^) locs k))
+                      (let ([x (car rest)])
+                        (case x
+                          [(#\() #\) ;;; vim paren-matching sucks
+                           (let-values ([(b* b*^ locs k)
+                                         (read-list p locs k 'rparen 'rbrack #t)])
+                             (g (cdr rest)
+                                (list (append a* b*))
+                                (list (append a*^ b*^))
+                                locs k))]
+                          [(#\[) #\] ;;;  vim paren-matching sucks
+                           (let-values ([(b* b*^ locs k)
+                                         (read-list p locs k 'rbrack 'rparen #t)])
+                             (g (cdr rest) 
+                                (list (append a* b*))
+                                (list (append a*^ b*^))
+                                locs k))]
+                          [else
+                           (let-values ([(inits rest) (split rest)])
+                             (let-values ([(s s^) (mksymbol inits)])
+                               (g rest
+                                  (cons s a*)
+                                  (cons s^ a*^)
+                                  locs k)))]))))))))
+        (define (read-at-bar-datum p locs k)
+          (let ([c (peek-char p)])
+            (cond
+              [(eof-object? c) (die/p p 'read "eof inside @|datum mode")]
+              [(char-whitespace? c)
+               (read-char p)
+               (read-at-bar-datum p locs k)]
+              [(char=? c #\|)
+               (read-char p)
+               (values '() '() locs k)]
+              [else 
+               (let-values ([(a a^ locs k) (read-expr p locs k)])
+                 (let-values ([(a* a*^ locs k) (read-at-bar-datum p locs k)])
+                   (values (cons a a*) (cons a^ a*^) locs k)))])))  
+        (define (read-at-text-mode p locs k)
+          (let ([c (peek-char p)])
+            (cond
+              [(eof-object? c) 
+               (die/p p 'read "eof encountered inside @-expression")]
+              [(char=? c #\|) 
+               (read-char p)
+               (read-at-bar p locs k #t)]
+              [else
+               (let-values ([(a a^ locs k)
+                             (read-at-sexpr-mode p locs k)])
+                 (values (list a) (list a^) locs k))])))
+        (define (read-at-sexpr-mode p locs k)
+          (let ([c (peek-char p)])
+            (cond
+              [(eof-object? c)
+               (die/p p 'read "eof encountered inside @-expression")]
+              [(eqv? c '#\[) ;;;   @[ ...
+               (read-char p)
+               (read-brackets p locs k)]
+              [(eqv? c #\{) ;;;   @{ ...
+               (read-char p)
+               (read-text p locs k '())]
+              [(char=? c #\|)
+               (read-char p)
+               (read-at-bar p locs k #f)]
+              [else            ;;;   @<cmd> ...
+               (let-values ([(a a^ locs k) (read-expr p locs k)])
+                 (let ([c (peek-char p)])
+                   (cond
+                     [(eof-object? c)  ;;; @<cmd><eof>
+                      (values a a^ locs k)]
+                     [(eqv? c #\[)
+                      (read-char p)
+                      (let-values ([(a* a*^ locs k)
+                                    (read-brackets p locs k)])
+                        (let ([v (cons a a*)] [v^ (cons a^ a*^)])
+                          (values v (annotate v v^ at-pos p) locs k)))]
+                     [(eqv? c #\{) ;;; @<cmd>{ ...
+                      (read-char p)
+                      (let-values ([(a* a*^ locs k)
+                                    (read-text p locs k '())])
+                        (let ([v (cons a a*)] [v^ (cons a^ a*^)])
+                          (values v (annotate v v^ at-pos p) locs k)))]
+                     [(eqv? c #\|) ;;; @<cmd>| ...
+                      (read-char p)
+                      (let-values ([(a* a*^ locs k)
+                                    (read-at-bar p locs k #f)])
+                        (let ([v (cons a a*)] [v^ (cons a^ a*^)])
+                          (values v (annotate v v^ at-pos p) locs k)))]
+                     [else 
+                      (values a a^ locs k)])))])))
+        (read-at-sexpr-mode p locs k)))
     (define parse-token
       (lambda (p locs k t pos)
         (cond
@@ -1028,6 +1406,8 @@
            (let-values ([(v v^ locs k) 
                          (read-bytevector p locs k 0 '())])
              (values v (annotate v v^ pos p) locs k))]
+          [(eq? t 'at-expr) 
+           (read-at-expr p locs k pos)]
           [(pair? t)
            (cond
              [(eq? (car t) 'datum) 
diff --git a/scheme/last-revision b/scheme/last-revision
index 684e8e3..ee91235 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1829
+1830
diff --git a/scheme/run-tests.ss b/scheme/run-tests.ss
index f5e2775..3d00dfe 100755
--- a/scheme/run-tests.ss
+++ b/scheme/run-tests.ss
@@ -23,7 +23,7 @@
   bitwise enums pointers sorting io fasl reader case-folding
   parse-flonums string-to-number bignum-to-flonum div-and-mod
   fldiv-and-mod unicode normalization repl set-position guardians
-  symbol-table))
+  symbol-table scribble))
 
 (define (run-test-from-library x)
   (printf "[testing ~a] ..." x)
diff --git a/scheme/tests/scribble.ss b/scheme/tests/scribble.ss
new file mode 100644
index 0000000..43b1050
--- /dev/null
+++ b/scheme/tests/scribble.ss
@@ -0,0 +1,522 @@
+
+(library (tests scribble)
+  (export run-tests)
+
+  (import (ikarus))
+
+  (define (run-tests) (test-scribble))
+
+  (define (test-scribble)
+
+    (define failed 0)
+    (define passed 0)
+    
+    (define (test-one str expected)
+      (guard (con
+               [else
+                (printf "======================================\n")
+                (display "testing scribble on:\n")
+                (display str)
+                (newline)
+                (printf "reads as\n")
+                (pretty-print expected)
+                (printf "test failed!\n")
+                (print-condition con)
+                (set! failed (+ failed 1))
+                (printf "FAILED ~s tests, PASSED ~s\n" failed passed)])
+        (let ([p (open-string-input-port str)])
+          (let ([v (read p)])
+            (unless (equal? v expected)
+              (error 'test "mismatch" v)))
+          (let ([v (read p)])
+            (unless (eof-object? v)
+              (error 'test "not eof" v))))
+        (set! passed (+ passed 1))
+        (printf " [~s]" passed)))
+    
+    (define-syntax tests
+      (lambda (x)
+        (define (process ls)
+          (cond
+            [(null? ls) #'(values)]
+            [else
+             (let ([x (syntax->datum (car ls))])
+               (assert (string? x))
+               (let f ([ac x] [ls (cdr ls)])
+                 (syntax-case ls (reads as)
+                   [(y rest ...) (string? (syntax->datum #'y))
+                    (f (string-append ac "\n" (syntax->datum #'y))
+                       #'(rest ...))]
+                   [(reads as foo rest ...)
+                    (with-syntax ([ac ac]
+                                  [rest (process #'(rest ...))])
+                      #'(begin (test-one ac 'foo) rest))])))]))
+        (syntax-case x ()
+          [(_ ls ...) 
+           (process #'(ls ...))])))
+    
+    (tests
+      "@foo{blah blah blah}" 
+        reads as 
+      (foo "blah blah blah")
+    
+      "@foo{blah \"blah\" (`blah'?)}"
+        reads as 
+      (foo "blah \"blah\" (`blah'?)")
+    
+      "@foo[1 2]{3 4}"
+        reads as
+      (foo 1 2 "3 4")
+    
+      "@foo[1 2 3 4]"
+        reads as
+      (foo 1 2 3 4)
+    
+      "@foo[:width 2]{blah blah}"
+        reads as
+      (foo :width 2 "blah blah")
+    
+      "@foo{blah blah"
+      "     yada yada}"
+        reads as
+      (foo "blah blah" "\n" "yada yada")
+    
+      "@foo{"
+      "  blah blah"
+      "  yada yada"
+      "}"
+        reads as
+      (foo "blah blah" "\n" "yada yada")
+    
+      "@foo{bar @baz{3}"
+      "     blah}"
+        reads as
+      (foo "bar " (baz "3") "\n" "blah")
+        
+      "@foo{@b{@u[3] @u{4}}"
+      "     blah}"
+        reads as
+      (foo (b (u 3) " " (u "4")) "\n" "blah")
+    
+      "@C{while (*(p++))"
+      "     *p = '\\n';}"
+        reads as 
+      (C "while (*(p++))" "\n" "  " "*p = '\\n';")
+    
+      "@{blah blah}"
+        reads as
+      ("blah blah")
+    
+      "@{blah @[3]}"
+        reads as
+      ("blah " (3))
+    
+      "'@{foo"
+      "   bar"
+      "   baz}"
+        reads as
+      '("foo" "\n" "bar" "\n" "baz")
+    
+      "@foo"
+        reads as
+      foo
+    
+      "@{blah @foo blah}"
+        reads as
+      ("blah " foo " blah")
+            
+      "@{blah @foo: blah}"
+        reads as
+      ("blah " foo: " blah")
+              
+      "@{blah @|foo|: blah}"
+        reads as 
+      ("blah " foo ": blah")
+    
+      "@foo{(+ 1 2) -> @(+ 1 2)!}"
+        reads as  
+      (foo "(+ 1 2) -> " (+ 1 2) "!")
+          
+      "@foo{A @\"string\" escape}"
+        reads as  
+      (foo "A string escape")
+    
+      "@foo{eli@\"@\"barzilay.org}"
+        reads as
+      (foo "eli@barzilay.org")
+        
+      "@foo{A @\"{\" begins a block}"
+        reads as  
+      (foo "A { begins a block")
+        
+      "@C{while (*(p++)) {"
+      "     *p = '\\n';"
+      "   }}"
+        reads as  
+      (C "while (*(p++)) {" "\n" "  "
+         "*p = '\\n';" "\n"
+         "}")
+        
+      "@foo|{bar}@{baz}|"
+        reads as  
+      (foo "bar}@{baz")
+        
+      "@foo|{bar |@x{X} baz}|"
+        reads as  
+      (foo "bar " (x "X") " baz")
+        
+      "@foo|{bar |@x|{@}| baz}|"
+        reads as  
+      (foo "bar " (x "@") " baz")
+      
+      "@foo|--{bar}@|{baz}--|"
+        reads as  
+      (foo "bar}@|{baz")
+        
+      "@foo|<<{bar}@|{baz}>>|"
+        reads as  
+      (foo "bar}@|{baz")
+      
+      ;;; ikarus does not allow \@identifier  
+      "(define |@email| \"foo@bar.com\")"
+        reads as  
+      (define |@email| "foo@bar.com")
+        
+      "(define |@atchar| #\\@)"
+        reads as  
+      (define |@atchar| #\@)
+      
+      "@foo{bar @baz[2 3] {4 5}}"
+        reads as  
+      (foo "bar " (baz 2 3) " {4 5}")
+        
+      "@{foo bar"
+      "  baz}"
+        reads as  
+      ("foo bar" "\n" "baz")
+        
+      "@foo{x @y z}"
+        reads as  
+      (foo "x " y " z")
+        
+      "@foo{x @(* y 2) z}"
+        reads as  
+      (foo "x " (* y 2) " z")
+        
+      "@{@foo bar}"
+        reads as  
+      (foo " bar")
+        
+      "@@foo{bar}{baz}"
+        reads as  
+      ((foo "bar") "baz")
+        
+      "@foo[1 (* 2 3)]{bar}"
+        reads as  
+      (foo 1 (* 2 3) "bar")
+        
+      "@foo[@bar{...}]{blah}"
+        reads as  
+      (foo (bar "...") "blah")
+        
+      "@foo[bar]"
+        reads as  
+      (foo bar)
+        
+      "@foo{bar @f[x] baz}"
+        reads as  
+      (foo "bar " (f x) " baz")
+        
+      "@foo[]{bar}"
+        reads as  
+      (foo "bar")
+        
+      "@foo[]"
+        reads as  
+      (foo)
+        
+      "@foo"
+        reads as  
+      foo
+        
+      "@foo{}"
+        reads as  
+      (foo)
+        
+      "@foo[:style 'big]{bar}"
+        reads as  
+      (foo :style 'big  "bar")
+        
+      "@foo{f{o}o}"
+        reads as  
+      (foo "f{o}o")
+        
+      "@foo{{{}}{}}"
+        reads as  
+      (foo "{{}}{}")
+        
+      "@foo{bar}"
+        reads as  
+      (foo "bar")
+        
+      "@foo{ bar }"
+        reads as  
+      (foo " bar ")
+        
+      "@foo[1]{ bar }"
+        reads as  
+      (foo 1 " bar ")
+      
+      "@foo{a @bar{b} c}"
+        reads as  
+      (foo "a " (bar "b") " c")
+        
+      "@foo{a @bar c}"
+        reads as  
+      (foo "a " bar " c")
+        
+      "@foo{a @(bar 2) c}"
+        reads as  
+      (foo "a " (bar 2) " c")
+      
+      "@foo{A @\"}\" marks the end}"
+        reads as  
+      (foo "A } marks the end")
+        
+      "@foo{The prefix: @\"@\".}"
+        reads as  
+      (foo "The prefix: @.")
+        
+      "@foo{@\"@x{y}\" --> (x \"y\")}"
+        reads as  
+      (foo "@x{y} --> (x \"y\")")
+        
+      "@foo|{...}|"
+        reads as  
+      (foo "...")
+        
+      "@foo|{\"}\" follows \"{\"}|"
+        reads as  
+      (foo "\"}\" follows \"{\"")
+        
+      "@foo|{Nesting |{is}| ok}|"
+        reads as  
+      (foo "Nesting |{is}| ok")
+      
+      "@foo|{Maze"
+      "      |@bar{is}"
+      "      Life!}|"
+        reads as  
+      (foo "Maze" "\n"
+           (bar "is") "\n"
+            "Life!")
+    
+      "@t|{In |@i|{sub|@\"@\"s}| too}|"
+        reads as  
+      (t "In " (i "sub@s") " too")
+      
+      "@foo|<<<{@x{foo} |@{bar}|.}>>>|"
+        reads as  
+      (foo "@x{foo} |@{bar}|.")
+        
+      "@foo|!!{X |!!@b{Y}...}!!|"
+        reads as  
+      (foo "X " (b "Y") "...")
+        
+      "@foo{foo@bar.}"
+        reads as  
+      (foo "foo" bar.)
+        
+      "@foo{foo@|bar|.}"
+        reads as  
+      (foo "foo" bar ".")
+        
+      "@foo{foo@3.}"
+        reads as  
+      (foo "foo" 3.0)
+        
+      "@foo{foo@|3|.}"
+        reads as  
+      (foo "foo" 3 ".")
+        
+      "@foo{foo@|(f 1)|{bar}}"
+        reads as  
+      (foo "foo" (f 1) "{bar}")
+        
+      "@foo{foo@|bar|[1]{baz}}"
+        reads as  
+      (foo "foo" bar "[1]{baz}")
+        
+      "@foo{x@\"y\"z}"
+        reads as  
+      (foo "xyz")
+        
+      "@foo{x@|\"y\"|z}"
+        reads as  
+      (foo "x" "y" "z")
+        
+      "@foo{x@|1 (+ 2 3) 4|y}"
+        reads as  
+      (foo "x" 1 (+ 2 3) 4 "y")
+        
+      "@foo{x@|*"
+      "        *|y}"
+        reads as  
+      (foo "x" * * "y")
+        
+      "@foo{Alice@||Bob@|"
+      "     |Carol}"
+        reads as  
+      (foo "Alice" "Bob" "Carol")
+      
+      "@|{blah}|"
+        reads as  
+      ("blah")
+      
+      "@foo{bar}"
+        reads as  
+      (foo "bar")
+        
+      "@foo{ bar }"
+        reads as  
+      (foo " bar ")
+        
+      "@foo{ bar"
+      "     baz }"
+        reads as  
+      (foo " bar" "\n" "baz ")
+        
+      "@foo{bar"
+      "}"
+        reads as  
+      (foo "bar")
+        
+        
+      "@foo{"
+      "  bar"
+      "}"
+        reads as  
+      (foo "bar")
+        
+      "@foo{"
+      " "
+      "  bar"
+      " "
+      "}"
+        reads as  
+      (foo "\n" "bar" "\n")
+        
+      "@foo{"
+      "  bar"
+      " "
+      "  baz"
+      "}"
+        reads as  
+      (foo "bar" "\n" "\n" "baz")
+        
+      "@foo{"
+      "}"
+        reads as  
+      (foo "\n")
+        
+      "@foo{"
+      " "
+      "}"
+        reads as  
+      (foo "\n" "\n")
+        
+      "@foo{ bar"
+      "     baz }"
+        reads as  
+      (foo " bar" "\n" "baz ")
+      
+      "@foo{"
+      "  bar"
+      "  baz"
+      "  blah"
+      "}"
+        reads as  
+      (foo "bar" "\n" "baz" "\n" "blah")
+        
+      "@foo{"
+      "  begin"
+      "    x++;"
+      "  end}"
+        reads as  
+      (foo "begin" "\n" "  " "x++;" "\n" "end")
+        
+      "@foo{"
+      "    a"
+      "   b"
+      "  c}"
+        reads as  
+      (foo "  " "a" "\n" " " "b" "\n" "c")
+        
+      "@foo{bar"
+      "       baz"
+      "     bbb}"
+        reads as  
+      (foo "bar" "\n" "  " "baz" "\n" "bbb")
+        
+      "@foo{ bar"
+      "        baz"
+      "      bbb}"
+        reads as  
+      (foo " bar" "\n" "   " "baz" "\n" " " "bbb")
+        
+      "@foo{bar"
+      "   baz"
+      "   bbb}"
+        reads as  
+      (foo "bar" "\n" "baz" "\n" "bbb")
+        
+      "@foo{ bar"
+      "   baz"
+      "   bbb}"
+        reads as  
+      (foo " bar" "\n" "baz" "\n" "bbb")
+        
+      "@foo{ bar"
+      "   baz"
+      "     bbb}"
+        reads as  
+      (foo " bar" "\n" "baz" "\n" "  " "bbb")
+        
+      "@text{Some @b{bold"
+      "  text}, and"
+      "  more text.}"
+        reads as  
+      (text "Some " (b "bold" "\n" "text")", and" "\n" "more text.")
+      
+      "@foo{"
+      "  @|| bar @||"
+      "  @|| baz}"
+        reads as  
+      (foo " bar " "\n" " baz")
+      
+      "@foo{@|xyz|}"
+      reads as 
+      (foo xyz)
+    
+      "@foo{@|<xyz>|}"
+      reads as 
+      (foo <xyz>)
+    
+      "@foo{@|<<<<|}"
+      reads as 
+      (foo <<<<)
+    
+      "@foo{@|<(x)>|}"
+      reads as
+      (foo < (x) >)
+    
+      "@foo{@|(<(<<)>) xy|}"
+      reads as
+      (foo (< (<<) >) xy)
+    
+    
+    )
+    (assert (= failed 0))))
+
+
+