Replace several define-macro' uses with syntax-rules' and `syntax-case'

tekuti/git.scm

@@ -56,9 +56,11 @@
   (output git-condition-output)
   (status git-condition-status))
 
-(define-macro (false-if-git-error . body)
+(define-syntax false-if-git-error
-  `(,guard (c ((,git-condition? c) #f))
+  (syntax-rules ()
-           ,@body))
+    ((_ body0 body ...)
+     (guard (c ((git-condition? c) #f))
+        body0 body ...))))
 
 ;;;
 ;;; running git

tekuti/request.scm

@@ -128,68 +128,80 @@
                                    #f)
                        #f)))))
 
-(define-macro (let-request request bindings . body)
+(define-syntax let-request
-  (let ((request-var (gensym)))
+  (lambda (stx)
     (define (make-binding b)
-      (cond
+      (syntax-case b ()
-       ((symbol? b) `(,b (,rref ,request-var ',b)))
+        ((id option ...)
-       ((list? b) `(,(car b) (,rref ,request-var ',(car b) ,@(cdr b))))
+         (identifier? #'id)
-       (else (error "what" b))))
+         #'(id (rref request-var 'id option ...)))
-    `(let ((,request-var ,request))
+        (id
-       (let (,@(map make-binding bindings))
+         (identifier? #'id)
-         ,@body))))
+         #'(id (rref request-var 'id)))))
+    (syntax-case stx ()
+      ((_ request (binding ...) body ...)
+       (with-syntax (((binding ...) (map make-binding #'(binding ...))))
+         #`(let ((request-var request))
+             (let (binding ...)
+               body ...)))))))
 
-(define-macro (path-proc-case path . clauses)
+(define-syntax path-proc-case
-  (let ((path-var (gensym)))
+  (lambda (stx)
     (define (optional-argument? arg)
-      (eqv? (string-ref arg (1- (string-length arg))) #\?))
+      (eqv? (string-ref arg (- (string-length arg) 1)) #\?))
     (define (required-argument? arg)
-      (eqv? (string-ref arg (1- (string-length arg))) #\!))
+      (eqv? (string-ref arg (- (string-length arg) 1)) #\!))
     (define (output-argument? arg)
       (or (optional-argument? arg) (required-argument? arg)))
     (define (process-clause clause)
-      (or (list-has-length? clause 2) (error "foo"))
+      (syntax-case clause (else)
-      (if (eq? (car clause) 'else)
+        ((else expr ...) clause)
-          clause
+        (((p ...) proc)
-          (let ((pat (map symbol->string (car clause)))
+         (let ((pat (map (lambda (p)
-                (proc (cadr clause)))
+                           (symbol->string (syntax->datum p)))
+                         #'(p ...))))
            (cond
             ((find-tail output-argument? pat)
              => (lambda (tail)
-                   (define test
+                  (let* ((req (find-tail required-argument? tail))
-                     (let* ((npat (length pat))
-                            (ntail (length tail))
-                            (req (find-tail required-argument? tail))
                          (opt (find-tail optional-argument? tail))
+                         (npat (length pat))
+                         (ntail (length tail))
                          (nopt (if opt (length opt) 0))
                          (nreq (if req (- (length req) nopt) 0)))
-                       (lambda (path)
+                    #`((let ((pathtail (list-head-match '#,pat
-                         (let ((pathtail (list-head-match pat path (- npat ntail))))
+                                                        path-var
-                           ;(pk pat npat ntail req opt nopt nreq path pathtail)
+                                                        (- #,npat #,ntail))))
-                           (if (and pathtail (>= (length pathtail) nreq)
+                         ;;(pk pat npat ntail req opt nopt nreq path pathtail)
-                                    (<= (length pathtail) (+ nreq nopt)))
+                         (if (and pathtail (>= (length pathtail) #,nreq)
-                               (append pathtail
+                                  (<= (length pathtail) (+ #,nreq #,nopt)))
-                                       (make-list (- (+ nreq nopt) (length pathtail)) #f))
+                             (append
-                               #f)))))
+                              pathtail
-                   `((,test ,path-var)
+                              (make-list (- (+ #,nreq #,nopt) (length pathtail)) #f))
+                             #f))
                        => (lambda (outargs)
                             (lambda args
-                            (apply ,proc (append args outargs)))))))
+                              (apply proc (append args outargs))))))))
             (else
-              `((equal? ,path-var ',pat) ,proc))))))
+             #`((equal? path-var '#,pat) proc)))))))
-    `(let ((,path-var ,path))
+    (syntax-case stx ()
-       (cond ,@(map process-clause clauses)))))
+      ((_ path clause ...)
+       (with-syntax (((cond-clause ...) (map process-clause #'(clause ...))))
+         #`(let ((path-var path))
+             (cond cond-clause ...)))))))
 
 (define (rcons*-fold request . keys-and-procs)
   (foldn (lambda (request k proc)
            (rcons k (proc request) request))
          2 request keys-and-procs))
 
-(define-macro (request-path-case request . clauses)
+(define-syntax request-path-case
-  `(,path-proc-case
+  (syntax-rules ()
-    (,let-request ,request (method path)
+    ((_ request clause ...)
+     (path-proc-case
+       (let-request request (method path)
                     (cons method path))
-    ,@clauses))
+       clause ...))))
 
 (define (request-server-name request)
   (let ((headers (rref request 'headers)))

tekuti/util.scm

@@ -36,7 +36,7 @@
             date-increment date-comparator date-before? date-after? compose1
             rfc822-date->timestamp timestamp->rfc822-date timestamp->atom-date
             timestamp->date string-split/trimming
-            list-intersperse with-backtrace with-time-debugging define-memoized))
+            list-intersperse with-backtrace with-time-debugging))
 
 (define (emailish? x)
   (match-bind "^([a-zA-Z0-9._+-]+)@([a-zA-Z0-9-]+\\.)+[a-zA-Z]+$"
@@ -88,36 +88,26 @@
           (string-join (cons (passwd:dir (getpwnam user)) (cdr parts)) "/"))
         path)))
 
-(define-macro (match-lines string pattern bindings expr)
+(define-syntax match-lines
-  (let ((line (gensym)) (seed (gensym)))
+  (syntax-rules ()
-    `(,fold
+    ((_ string pattern bindings expr)
-      (lambda (,line ,seed)
+     (let ((rx (irregex pattern)))
-        (,match-bind ,pattern ,line ,bindings
+       (fold
-                     (cons ,expr ,seed)
+        (lambda (line seed)
-                     ,seed))
+          (match-bind rx line bindings
-      '() (string-split ,string #\newline))))
+                      (cons expr seed)
-
+                      seed))
-;; clause := ((pat args) body...)
+        '() (string-split string #\newline))))))
-(define-macro (match-case string . clauses)
-  (let ((str (gensym)))
-    `(let ((,str ,string))
-       ,(let lp ((in clauses))
-          (let ((clause (car in)))
-            (if (eq? (car clause) 'else)
-                `(begin ,@(cdr clause))
-                `(match-bind ,(caar clause) ,str ,(cadar clause)
-                             (begin ,@(cdr clause))
-                             ,(if (null? (cdr in))
-                                  #f
-                                  (lp (cdr in))))))))))
 
 (define (dbg fmt . args)
   (apply format (current-error-port) fmt args))
 
-(define-macro (unwind-protect form . cleanups)
+(define-syntax unwind-protect
-  `(dynamic-wind (lambda () #t)
+  (syntax-rules ()
-       (lambda () ,form)
+    ((_ form cleanup0 cleanups ...)
-       (lambda () ,@cleanups)))
+     (dynamic-wind (lambda () #t)
+                   (lambda () form)
+                   (lambda () cleanup0 cleanups ...)))))
 
 (define (dsu-sort list key less)
   (map cdr
@@ -196,8 +186,10 @@
                         (fluid-set! the-last-stack (make-stack #t 2 0))
                         (apply throw args)))))
 
-(define-macro (with-backtrace . forms)
+(define-syntax with-backtrace
-  `(,with-backtrace* (lambda () ,@forms)))
+  (syntax-rules ()
+    ((_ form0 forms ...)
+     (with-backtrace* (lambda () form0 forms ...)))))
 
 (define (gettimeofday-diff prev)
   (let ((now (gettimeofday)))
@@ -211,8 +203,10 @@
      (proc)
      (pk 'stop-clock (gettimeofday-diff start)))))
 
-(define-macro (with-time-debugging . forms)
+(define-syntax with-time-debugging
-  `(,with-time-debugging* (lambda () ,@forms)))
+  (syntax-rules ()
+    ((_ form0 forms ...)
+     (with-time-debugging* (lambda () form0 forms ...)))))
 
 (define (memoize1 proc)
   (let ((old-args #f) (cache #f) (proc proc))
@@ -224,11 +218,6 @@
             (set! cache val)
             val)))))
 
-(define-macro (define-memoized form . body)
-  `(begin
-     (define ,form ,@body)
-     (set! ,(car form) (,memoize1 ,(car form)))))
-
 (define (write-hash h)
   (write (hash-fold acons '() h)))
 

tekuti/web.scm

@@ -32,7 +32,7 @@
   #:use-module (tekuti template)
   #:use-module (tekuti page)
   #:use-module (srfi srfi-1)
-  #:export (let-headers header-ref
+  #:export (header-ref
             handle-request))
             
 (define *status-names*
@@ -53,17 +53,6 @@
    "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" "
    "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n"))
 
-;;; useless macro
-(define-macro (let-headers headers bindings . body)
-  (let ((headers-var (gensym)))
-    `(let ((,headers-var ,headers))
-       (let (,@(map (lambda (binding)
-                      `(,(car binding)
-                        (or (assoc-ref ,headers-var ,(cadr binding))
-                            (error "Missing header:" ,(cadr binding)))))
-                    bindings))
-         ,@body))))
-
 (define (make-output request)
   (lambda (port)
     (let ((sxml (or (rref request 'sxml #f)