From b50c10efa2a2d477f6fd6c41558757e3976471a3 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Wed, 30 Sep 2009 20:28:02 +0000
Subject: [PATCH] using scribble/text now

svn: r16192
---
 src/mzscheme/src/makeexn | 322 +++++++++++++++++++--------------------
 1 file changed, 157 insertions(+), 165 deletions(-)

diff --git a/src/mzscheme/src/makeexn b/src/mzscheme/src/makeexn
index f22b6d2df6..c1149e1e0f 100755
--- a/src/mzscheme/src/makeexn
+++ b/src/mzscheme/src/makeexn
@@ -7,60 +7,62 @@ else
 fi
 |#
 
-#lang scheme
+#lang at-exp scheme
 
 (provide main)
 (define (main [arg #f])
   (if (equal? arg "doc") (print-doc) (print-header)))
 
-(require "exnsrc.ss")
+(require "exnsrc.ss" scribble/text)
 
 (define l info)
 
-(define-struct ex (define string base doc args props guard parent parent-def numtotal depth mark))
+(define-struct ex (define string base doc args props guard parent parent-def
+                   numtotal depth mark))
 (define-struct fld (name type doc))
 (define-struct prop (scheme-name c-name value))
 
 (define max-exn-args 0)
 
-(define (make-an-ex sym parent parent-def parent-name totalargs args props guard doc depth mark)
+(define (make-an-ex sym parent parent-def parent-name totalargs args props
+                    guard doc depth mark)
   (let* ([s (symbol->string sym)]
-	 [name (string-append parent-name 
-			      (if (string=? "" parent-name) "" ":") 
-			      s)]
-	 [count (+ totalargs (length args))])
+         [name (string-append parent-name
+                              (if (string=? "" parent-name) "" ":")
+                              s)]
+         [count (+ totalargs (length args))])
     (when (> count max-exn-args)
-	  (set! max-exn-args count))
+          (set! max-exn-args count))
     (make-ex (string-append "MZ"
-			    (list->string
-			     (let loop ([l (string->list name)])
-			       (cond
-				[(null? l) '()]
-				[(or (char=? (car l) #\:)
-				     (char=? (car l) #\/)
-				     (char=? (car l) #\-))
-				 (cons #\_ (loop (cdr l)))]
-				[else
-				 (cons (char-upcase (car l))
-				       (loop (cdr l)))]))))
-	     name
-	     sym
-	     doc
-	     args
-	     props
-	     guard
-	     parent
-	     parent-def
-	     count
-	     depth
-	     mark)))
+                            (list->string
+                             (let loop ([l (string->list name)])
+                               (cond
+                                [(null? l) '()]
+                                [(or (char=? (car l) #\:)
+                                     (char=? (car l) #\/)
+                                     (char=? (car l) #\-))
+                                 (cons #\_ (loop (cdr l)))]
+                                [else
+                                 (cons (char-upcase (car l))
+                                       (loop (cdr l)))]))))
+             name
+             sym
+             doc
+             args
+             props
+             guard
+             parent
+             parent-def
+             count
+             depth
+             mark)))
 
 (define (make-arg-list args)
   (cond
    [(null? args) '()]
    [(string? (cadar args))
     (cons (apply make-fld (car args))
-	  (make-arg-list (cdr args)))]
+          (make-arg-list (cdr args)))]
    [else
     (make-arg-list (cdr args))]))
 
@@ -69,7 +71,7 @@ fi
    [(null? args) '()]
    [(symbol? (cadar args))
     (cons (apply make-prop (car args))
-	  (make-prop-list (cdr args)))]
+          (make-prop-list (cdr args)))]
    [else
     (make-prop-list (cdr args))]))
 
@@ -78,34 +80,34 @@ fi
    [(null? v) '()]
    [else
     (let*-values ([(s mark)
-		  (let* ([s (symbol->string (car v))]
-			 [c (string-ref s 0)])
-		    (if (or (char=? #\* c)
-			    (char=? #\+ c))
-			(values (string->symbol (substring s 1 (string-length s))) c)
-			(values (car v) #f)))]
-		 [(e) (make-an-ex s parent parent-def parent-name totalargs 
-				  (if (null? (cadr v))
-				      null
-				      (make-arg-list (cdadr v)))
-				  (if (null? (cadr v))
-				      null
-				      (make-prop-list (cdadr v)))
-				  (if (null? (cadr v))
-				      #f
-				      (caadr v))
-				  (caddr v) depth mark)])
+                  (let* ([s (symbol->string (car v))]
+                         [c (string-ref s 0)])
+                    (if (or (char=? #\* c)
+                            (char=? #\+ c))
+                        (values (string->symbol (substring s 1 (string-length s))) c)
+                        (values (car v) #f)))]
+                 [(e) (make-an-ex s parent parent-def parent-name totalargs
+                                  (if (null? (cadr v))
+                                      null
+                                      (make-arg-list (cdadr v)))
+                                  (if (null? (cadr v))
+                                      null
+                                      (make-prop-list (cdadr v)))
+                                  (if (null? (cadr v))
+                                      #f
+                                      (caadr v))
+                                  (caddr v) depth mark)])
       (cons e
        (apply append
-	      (map
-	       (lambda (v)
-		 (make-struct-list v 
-				   e
-				   (ex-define e)
-				   (ex-string e)
-				   (ex-numtotal e)
-				   (add1 depth)))
-	       (cdddr v)))))]))
+              (map
+               (lambda (v)
+                 (make-struct-list v
+                                   e
+                                   (ex-define e)
+                                   (ex-string e)
+                                   (ex-numtotal e)
+                                   (add1 depth)))
+               (cdddr v)))))]))
 
 (set! l (make-struct-list l #f #f "" 0 0))
 
@@ -113,10 +115,9 @@ fi
   (string-length (symbol->string s)))
 
 (define (clean-help-desk-type type)
-  (regexp-replace* 
-   "or-{\\\\scmfalse}"
-   (regexp-replace* " " type "-")
-   "or-#f"))
+  (regexp-replace* "or-{\\\\scmfalse}"
+                   (regexp-replace* " " type "-")
+                   "or-#f"))
 
 (define (print-doc)
   (printf "% This file was generated by makeexn~n")
@@ -133,7 +134,7 @@ fi
                    (string-append (format "\\exn~atab{}" pre)
                                   (loop (sub1 d)))])))])
        (display (tab ""))
-       (printf "\\exntype{~a}{~a}{~a}{~a} " 
+       (printf "\\exntype{~a}{~a}{~a}{~a} "
                (ex-base e)
                (ex-string e)
                (case (ex-mark e)
@@ -158,18 +159,18 @@ fi
                          [(null? l) s]
                          [s (loop (cdr l) (string-append s " " (make-var (car l))))]
                          [else (loop (cdr l) (make-var (car l)))]))))))
-       
+
        (if (eq? (ex-doc e) '-)
          (printf "\\exnusenone{~a} " (tab ""))
          (printf "\\exnuse{~a}{~a}{~a} " (tab "") (ex-doc e)
                  (- 6.3 (* 0.08 (symbol-length (ex-base e))) (* 0.25 (ex-depth e)))))
-       
+
        (let ([args (ex-args e)]
              [print-one
               (lambda (f)
-                (printf "\\exnfield{~a}{~a}{~s}{~a}{~a} " 
+                (printf "\\exnfield{~a}{~a}{~s}{~a}{~a} "
                         (fld-name f) (ex-string e)
-                        (- 5.4 (* 0.08 (symbol-length (fld-name f))) (* 0.25 (ex-depth e))) (fld-doc f) 
+                        (- 5.4 (* 0.08 (symbol-length (fld-name f))) (* 0.25 (ex-depth e))) (fld-doc f)
                         (fld-type f)))])
          (unless (null? args)
            (printf "\\exnbeginfields{~a} " (tab ""))
@@ -186,100 +187,91 @@ fi
   (display "\\end{exntable}\n"))
 
 (define (print-header)
-  (printf "/* This file was generated by makeexn */~n")
-  (printf "#ifndef _MZEXN_DEFINES~n")
-  (printf "#define _MZEXN_DEFINES~n~n")
-  (printf "enum {~n")
-  (for-each (lambda (e) (printf "  ~a,~n" (ex-define e)))
-            l)
-  (printf "  MZEXN_OTHER~n};~n~n")
-  (printf "#endif~n~n")
-  (printf "#ifdef _MZEXN_TABLE~n~n")
-  (printf "#define MZEXN_MAXARGS ~a~n~n" max-exn-args)
-  (printf "#ifdef GLOBAL_EXN_ARRAY~n")
-  (printf "static exn_rec exn_table[] = {~n")
-  (let loop ([ll l])
-    (let ([e (car ll)])
-      (printf "  { ~a, NULL, NULL, 0, NULL, ~a }" 
-              (ex-numtotal e)
-              (if (ex-parent e)
-                (let loop ([pos 0][ll l])
-                  (if (eq? (car ll) (ex-parent e))
-                    pos
-                    (loop (add1 pos) (cdr ll))))
-                -1))
-      (unless (null? (cdr ll))
-        (printf ",~n")
-        (loop (cdr ll)))))
-  (printf "~n};~n")
-  (printf "#else~n")
-  (printf "static exn_rec *exn_table;~n")      
-  (printf "#endif~n")
-  (printf "~n#endif~n~n")
-  (printf "#ifdef _MZEXN_PRESETUP~n~n")
-  (printf "#ifndef GLOBAL_EXN_ARRAY~n")
-  (printf "  exn_table = (exn_rec *)scheme_malloc(sizeof(exn_rec) * MZEXN_OTHER);~n")
-  (let loop ([l l])
-    (let ([e (car l)])
-      (printf "  exn_table[~a].args = ~a;~n"
-              (ex-define e)
-              (ex-numtotal e))
-      (unless (null? (cdr l))
-        (loop (cdr l)))))
-  (printf "#endif~n")
-  (printf "~n#endif~n~n")
-  (printf "#ifdef _MZEXN_DECL_FIELDS~n~n")
-  (for-each
-   (lambda (e)
-     (let ([l (ex-args e)])
-       (unless (null? l)
-         (printf "static const char *~a_FIELDS[~s] = { \"~a\"" 
-                 (ex-define e) (length l) (fld-name (car l)))
-         (for-each
-          (lambda (field)
-            (printf ", \"~a\"" (fld-name field)))
-          (cdr l))
-         (printf " };~n"))))
-   l)
-  (printf "~n#endif~n~n")
-  (printf "#ifdef _MZEXN_DECL_PROPS~n~n")
-  (for-each
-   (lambda (e)
-     (let ([l (ex-props e)])
-       (unless (null? l)
-         (printf "#define ~a_PROPS " (ex-define e))
-         (let loop ([l l])
-           (if (null? l)
-             (printf "scheme_null")
-             (begin
-               (printf "scheme_make_pair(")
-               (printf "scheme_make_pair(~a, ~a), "
-                       (prop-c-name (car l)) 
-                       (prop-value (car l)))
-               (loop (cdr l))
-               (printf ")"))))
-         (printf "~n"))))
-   l)
-  (printf "~n#endif~n~n")
-  (printf "#ifdef _MZEXN_SETUP~n~n")
-  (for-each
-   (lambda (e)
-     (printf "  SETUP_STRUCT(~a, ~a, ~s, ~a, ~a, ~a, ~a)~n"
-             (ex-define e)
-             (let ([p (ex-parent-def e)])
-               (if p
-                 (format "EXN_PARENT(~a)" p)
-                 #cs'NULL))
-             (ex-string e)
-             (length (ex-args e))
-             (if (null? (ex-args e))
-               "NULL"
-               (format "~a_FIELDS" (ex-define e)))
-             (if (null? (ex-props e))
-               "scheme_null"
-               (format "~a_PROPS" (ex-define e)))
-             (if (ex-guard e)
-               (format "scheme_make_prim(~a)" (ex-guard e))
-               "NULL")))
-   l)
-  (printf "~n#endif~n"))
+  @(compose output list){
+    /* This file was generated by makeexn */
+    #ifndef _MZEXN_DEFINES
+    #define _MZEXN_DEFINES
+    enum {
+    @(add-newlines (for/list ([e l]) @list{  @(ex-define e),}))
+      MZEXN_OTHER
+    };
+    #endif
+
+    #ifdef _MZEXN_TABLE
+
+    #define MZEXN_MAXARGS @max-exn-args
+
+    #ifdef GLOBAL_EXN_ARRAY
+    static exn_rec exn_table[] = {
+    @(let loop ([ll l])
+       (let ([e (car ll)])
+         (cons @list{  { @(ex-numtotal e), NULL, NULL, 0, NULL, @;
+                         @(if (ex-parent e)
+                            (let loop ([pos 0][ll l])
+                              (if (eq? (car ll) (ex-parent e))
+                                pos
+                                (loop (add1 pos) (cdr ll))))
+                            -1) }}
+               (if (null? (cdr ll))
+                 '()
+                 (cons ",\n" (loop (cdr ll)))))))
+    };
+    #else
+    static exn_rec *exn_table;
+    #endif
+
+    #endif
+
+    #ifdef _MZEXN_PRESETUP
+
+    #ifndef GLOBAL_EXN_ARRAY
+      exn_table = (exn_rec *)scheme_malloc(sizeof(exn_rec) * MZEXN_OTHER);
+    @(add-newlines
+      (for/list ([e l])
+        @list{  exn_table[@(ex-define e)].args = @(ex-numtotal e)@";"}))
+    #endif
+
+    #endif
+
+    #ifdef _MZEXN_DECL_FIELDS
+    @(add-newlines
+      (for*/list ([e l] [l (in-value (ex-args e))] #:when (pair? l))
+        (define fields
+          (add-between (map (lambda (f) @list{"@(fld-name f)"}) l) ", "))
+        @list{  static const char *@(ex-define e)_FIELDS[@(length l)] = @;
+                 { @fields };
+              }))
+    #endif
+
+    #ifdef _MZEXN_DECL_PROPS
+    @(add-newlines
+      (for*/list ([e l] [l (in-value (ex-props e))] #:when (pair? l))
+        (define (acons x y l)
+          @list{scheme_make_pair(scheme_make_pair(@x, @y), @l)})
+        @list{#  define @(ex-define e)_PROPS @;
+              @(let loop ([l l])
+                 (if (null? l)
+                   "scheme_null"
+                   (acons (prop-c-name (car l)) (prop-value (car l))
+                          (loop (cdr l)))))}))
+    #endif
+
+    #ifdef _MZEXN_SETUP
+    @(add-newlines
+      (for/list ([e l])
+        @list{  SETUP_STRUCT(@(ex-define e), @;
+                             @(let ([p (ex-parent-def e)])
+                                (if p @list{EXN_PARENT(@p)} 'NULL)), @;
+                             "@(ex-string e)", @;
+                             @(length (ex-args e)), @;
+                             @(if (null? (ex-args e))
+                                'NULL
+                                @list{@(ex-define e)_FIELDS}), @;
+                             @(if (null? (ex-props e))
+                                'scheme_null
+                                @list{@(ex-define e)_PROPS}), @;
+                             @(if (ex-guard e)
+                                @list{scheme_make_prim(@(ex-guard e))}
+                                'NULL))}))
+    #endif
+    @||})