Re: Is gentemp or gensym "safe"?

[Dale P. Smith]

Rob Browning wrote:
> For example, I've seen:
> 
>   (define-syntax foo
>     (syntax-case ()
>       ((foo ()) something)
>       ((foo (x-1 x-2 ...)) (foo "do-something-internal" x-1 x-2 ...))
>       ((foo "do-something-internal" x ...) blah-blah-blah)
>       etc.))
> 
> so the author uses a bunch of strings in normally illegal places to
> handle branching to cases that finish the processing.  However, this I
> presume means that you've now make things like
> 
>   (foo "do-something-internal" 1 2)
> 
> legal syntax which IMO is broken.
> 
> That's why I was trying to create the hidden "helper" macros.

That looks similar to the huge macros that are in brl.  This is what
some of the ported brl code looks like in my experimental mod_guile
Apache module.  I don't have any hard timings, but the first time a page
loads seemes to take about two seconds.  The first time a page is
loaded, it is wrapped in a lambda and stored in a hash table.  Reloads
of the same page are very fast, about the time it takes to redraw the
netscape window.  But that's my impression.

Here is one of the macros for your enjoyment:

(define-syntax sql-repeat-rsmd
  (syntax-rules (!body! group-beginning? group-ending?
                        quote define set! lambda let let* letrec
                        case brl-url-args else)

    ;; Translate (group-beginning? expr) and (group-ending? expr)
    ;; according to changing values
    ((sql-repeat-rsmd !body! args prior-row sql-row next-row
              (group-beginning? expr))
     (sql-change? (lambda args expr) sql-row prior-row))

    ((sql-repeat-rsmd !body! args prior-row sql-row next-row
              (group-ending? expr))
     (sql-change? (lambda args expr) sql-row next-row))

    ; Handle various scheme syntaxes
    ((sql-repeat-rsmd !body! args prior-row sql-row next-row
              (quote expr))
     (quote expr))

    ((sql-repeat-rsmd !body! args prior-row sql-row next-row
              (define name expr ...))
     (define name (sql-repeat-rsmd !body! args prior-row sql-row
next-row (begin expr ...))))

    ((sql-repeat-rsmd !body! args prior-row sql-row next-row
              (set! name expr ...))
     (set! name (sql-repeat-rsmd !body! args prior-row sql-row next-row
(begin expr ...))))

    ((sql-repeat-rsmd !body! args prior-row sql-row next-row
              (lambda formals expr ...))
     (lambda formals (sql-repeat-rsmd !body! args prior-row sql-row
next-row (begin expr ...))))

    ((sql-repeat-rsmd !body! args prior-row sql-row next-row
              (let ((var init) ...) expr ...))
     (let ((var (sql-repeat-rsmd !body! args prior-row sql-row next-row
init)) ...)
       (sql-repeat-rsmd !body! args prior-row sql-row next-row expr)
...))

    ((sql-repeat-rsmd !body! args prior-row sql-row next-row
              (let* ((var init) ...) expr ...))
     (let* ((var (sql-repeat-rsmd !body! args prior-row sql-row next-row
init)) ...)
       (sql-repeat-rsmd !body! args prior-row sql-row next-row expr)
...))

    ((sql-repeat-rsmd !body! args prior-row sql-row next-row
              (letrec ((var init) ...) expr ...))
     (letrec ((var (sql-repeat-rsmd !body! args prior-row sql-row
next-row init)) ...)
       (sql-repeat-rsmd !body! args prior-row sql-row next-row expr)
...))

    ;; case syntax
    ((sql-repeat-rsmd !body! args prior-row sql-row next-row
              (case key (expr1 expr2) ...))
     (case (sql-repeat-rsmd !body! args prior-row sql-row next-row key)
       (expr1 (sql-repeat-rsmd !body! args prior-row sql-row next-row
expr2)) ...))

    ;; brl-url-args syntax
    ((sql-repeat-rsmd !body! args prior-row sql-row next-row
                      (brl-url-args blank? var ...))
     (brl-url-args-proc
      (sql-repeat-rsmd !body! args prior-row sql-row next-row blank?)
      (quote (var ...))
      (list var ...)))

    ;; begin syntax
    ((sql-repeat-rsmd !body! args prior-row sql-row next-row
              (begin expr ...))
     (begin (sql-repeat-rsmd !body! args prior-row sql-row next-row
expr) ...))
     ;;(begin expr ...))

    ;; Procedure application and other simple syntax
    ((sql-repeat-rsmd !body! args prior-row sql-row next-row
              (expr ...))
     ((sql-repeat-rsmd !body! args prior-row sql-row next-row expr)
...))

    ((sql-repeat-rsmd !body! args prior-row sql-row next-row
              expr)
     expr)

    ;; And now the base case:
    ((sql-repeat-rsmd rsmd statement args (query ...) expr ...)
     (let* ((sql-results
             (sql-execute-query statement
                                (apply string-append (map brl-string
                                                          (list query ...)))))
            (rsmd (sql-rsmd sql-results))
            (sql-column-count (sql-rsmd-column-count rsmd))
            (first-row (sql-resultset-nextrow sql-results sql-column-count)))
       (do ((sql-row first-row next-row)
            (next-row (if first-row
                          (sql-resultset-nextrow sql-results sql-column-count)
                          #f)
                      (if next-row
                          (sql-resultset-nextrow sql-results sql-column-count)
                          #f))
            (prior-row #f sql-row)
            (sql-rowcount 1 (+ sql-rowcount 1)))
           ((not sql-row) (- sql-rowcount 1))
         (apply (lambda args
                  (sql-repeat-rsmd !body! args prior-row sql-row next-row
                                   (begin expr ...)))
                sql-row))))))

(define-syntax sql-repeat
  (syntax-rules ()
    ((sql-repeat statement args (query ...) expr ...)
     (sql-repeat-rsmd rsmd statement args (query ...) expr ...))))

-Dale

-- 
Dale P. Smith
Treasurer, Cleveland Linux Users Group http://cleveland.lug.net
Senior Systems Consultant, Altus Technologies Corporation
address@hidden
440-746-9000 x309