exnsrc.ss is now a module; works with v4 now

svn: r16189

src/mzscheme/src/exnsrc.ss

@@ -1,3 +1,4 @@
+#lang scheme
 
 #|
 
@@ -7,7 +8,9 @@ propeties (the latter in curly braces), strings are contracts/comments.
 
 |#
 
-#cs
+(provide info)
+(define info '
+
 (exn [exn_field_check
       (message "immutable string" "error message")
       (continuation-marks "mark set"
@@ -44,10 +47,10 @@ propeties (the latter in curly braces), strings are contracts/comments.
              (continuation "escape continuation" "resumes from the break")]
             "asynchronous break signal"))
 
+)
 
 #|
 Not an exception in the above sense:
      (special-comment [width "non-negative exact integer" "width of the special comment in port positions"]
         "raised by a custom input port's special-reading procedure")
 |#
-

src/mzscheme/src/makeexn

@@ -1,13 +1,21 @@
 #!/bin/sh
 #|
-if [ "$PLTHOME" = "" ] ; then PLTHOME=/usr/local/lib/plt ; export PLTHOME ; fi
+if [ "$PLTHOME" = "" ]; then
-exec ${PLTHOME}/bin/mzscheme -gqr $0 "$@"
+  exec mzscheme -um "$0" "$@"
+else
+  exec ${PLTHOME}/bin/mzscheme -um $0 "$@"
+fi
 |#
 
-(define doc? (and (= (vector-length argv) 1)
+#lang scheme
-		  (string=? (vector-ref argv 0) "doc")))
 
-(define l (read))
+(provide main)
+(define (main [arg #f])
+  (if (equal? arg "doc") (print-doc) (print-header)))
+
+(require "exnsrc.ss")
+
+(define l info)
 
 (define-struct ex (define string base doc args props guard parent parent-def numtotal depth mark))
 (define-struct fld (name type doc))
@@ -99,13 +107,7 @@ exec ${PLTHOME}/bin/mzscheme -gqr $0 "$@"
 				   (add1 depth)))
 	       (cdddr v)))))]))
 
-(define l (make-struct-list l
+(set! l (make-struct-list l #f #f "" 0 0))
-			    #f
-			    #f
-			    ""
-			    0
-			    0))
-
 
 (define (symbol-length s)
   (string-length (symbol->string s)))
@@ -116,8 +118,7 @@ exec ${PLTHOME}/bin/mzscheme -gqr $0 "$@"
    (regexp-replace* " " type "-")
    "or-#f"))
 
-(if doc?
+(define (print-doc)
-    (begin
   (printf "% This file was generated by makeexn~n")
   (display "\\begin{exntable}\n")
   (for-each
@@ -183,29 +184,22 @@ exec ${PLTHOME}/bin/mzscheme -gqr $0 "$@"
        (newline)))
    l)
   (display "\\end{exntable}\n"))
-    (begin
-      (printf "/* This file was generated by makeexn */~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
+  (for-each (lambda (e) (printf "  ~a,~n" (ex-define e)))
-       (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)
@@ -214,24 +208,19 @@ exec ${PLTHOME}/bin/mzscheme -gqr $0 "$@"
                     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))
@@ -239,28 +228,21 @@ exec ${PLTHOME}/bin/mzscheme -gqr $0 "$@"
         (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)
+                 (ex-define e) (length l) (fld-name (car l)))
-			   (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)])
@@ -278,11 +260,8 @@ exec ${PLTHOME}/bin/mzscheme -gqr $0 "$@"
                (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"
@@ -303,5 +282,4 @@ exec ${PLTHOME}/bin/mzscheme -gqr $0 "$@"
                (format "scheme_make_prim(~a)" (ex-guard e))
                "NULL")))
    l)
-
+  (printf "~n#endif~n"))
-      (printf "~n#endif~n")))