yet more v4-isms

svn: r11684

collects/handin-server/checker.ss

@@ -191,10 +191,8 @@
 ;; This code will hack textualization of text boxes
 
 (define (insert-to-editor editor . xs)
-  (for-each (lambda (x)
-              (send editor insert
-                    (if (string? x) x (make-object editor-snip% x))))
-            xs))
+  (for ([x xs])
+    (send editor insert (if (string? x) x (make-object editor-snip% x)))))
 
 ;; support for "text-box%"
 (define text-box-sc
@@ -284,10 +282,9 @@
                                 '(ok-cancel caution)))))
         (error* "Aborting...")))
     ;; This will create copies of the original files
-    ;; (for-each (lambda (file)
+    ;; (for ([file files])
     ;;   (with-output-to-file (car file)
     ;;     (lambda () (display (cadr file)) (flush-output))))
-    ;;           files)
     (let* ([pfx-len  (string-length markup-prefix)]
            [line-len (- maxwidth pfx-len)]
            [=s       (lambda (n) (if (<= 0 n) (make-string n #\=) ""))]
@@ -301,14 +298,12 @@
         (display ===)
         (newline))
       (parameterize ([current-output-port (open-output-bytes)])
-        (for-each (lambda (file)
+        (for ([file files])
           (sep (car file))
-                    (parameterize ([current-input-port
-                                    (open-input-bytes (cadr file))]
+          (parameterize ([current-input-port (open-input-bytes (cadr file))]
                          [current-processed-file (car file)])
             (input->process->output
              maxwidth textualize? untabify? prefix-re)))
-                  files)
         (get-output-bytes (current-output-port))))))
 
 ;; ============================================================================
@@ -394,10 +389,9 @@
             [user-post      (id 'user-post)]
             [(body ...) (syntax-case #'(body ...) ()
                           [() #'(void)] [_ #'(body ...)])])
-         (for-each (lambda (x)
+         (for ([x keyvals])
            (unless (memq (car x) got)
              (raise-syntax-error #f "unknown keyword" stx (cadr x))))
-                   keyvals)
          #'(begin
              (provide checker)
              (define checker
@@ -476,10 +470,8 @@
                      (set-run-status "creating text file")
                      (with-output-to-file text-file #:exists 'truncate
                        (lambda ()
-                         (for-each (lambda (user)
-                                     (prefix-line
-                                      (user-substs user student-line)))
-                                   users)
+                         (for ([user users])
+                           (prefix-line (user-substs user student-line)))
                          (for-each prefix-line/substs extra-lines)
                          (for-each prefix-line/substs
                                    (or (thread-cell-ref added-lines) '()))

collects/handin-server/main.ss

@@ -24,7 +24,7 @@
   (error (apply format fmt args)))
 
 (define (write+flush port . xs)
-  (for-each (lambda (x) (write x port) (newline port)) xs)
+  (for ([x xs]) (write x port) (newline port))
   (flush-output port))
 
 (define-struct alist (name [l #:mutable]))
@@ -87,8 +87,7 @@
       ;; SUCCESS, or things that are newer in the main submission
       ;; directory are kept (but subdirs in SUCCESS will are copied as
       ;; is))
-      (for-each
-       (lambda (f)
+      (for ([f (directory-list dir)])
         (define dir/f (build-path dir f))
         (cond [(not (or (file-exists? f) (directory-exists? f)))
                ;; f is in dir but not in the working directory
@@ -99,8 +98,7 @@
                         (not (= (file-size f) (file-size dir/f)))))
                ;; f is newer in dir than in the working directory
                (delete-directory/files f)
-                (copy-directory/files dir/f f)]))
-       (directory-list dir)))))
+               (copy-directory/files dir/f f)])))))
 
 (define cleanup-sema (make-semaphore 1))
 (define (cleanup-submission dir)
@@ -118,14 +116,12 @@
 
 (define (cleanup-all-submissions)
   (log-line "Cleaning up all submission directories")
-  (for-each (lambda (pset)
-              (when (directory-exists? pset) ; just in case
+  (for ([pset (get-conf 'all-dirs)]
+        #:when (directory-exists? pset)) ; just in case
     (parameterize ([current-directory pset])
-                  (for-each (lambda (sub)
-                              (when (directory-exists? sub) ; filter non-dirs
-                                (cleanup-submission sub)))
-                            (directory-list)))))
-            (get-conf 'all-dirs)))
+      (for ([sub (directory-list)]
+            #:when (directory-exists? sub)) ; filter non-dirs
+        (cleanup-submission sub)))))
 
 ;; On startup, we scan all submissions, then repeat at random intervals (only
 ;; if clients connected in that time), and check often for changes in the
@@ -193,15 +189,11 @@
       ;; we have a submission, need to create a directory if needed, make
       ;; sure that no users submitted work with someone else
       (unless (directory-exists? dirname)
-        (for-each
-         (lambda (dir)
-           (for-each
-            (lambda (d)
+        (for* ([dir (directory-list)]
+               [d (regexp-split #rx" *[+] *" (path->string dir))])
           (when (member d users)
             (error* "bad submission: ~a has an existing submission (~a)"
                     d dir)))
-            (regexp-split #rx" *[+] *" (path->string dir))))
-         (directory-list))
         (make-directory dirname))
       (parameterize ([current-directory dirname]
                      [current-messenger
@@ -378,9 +370,9 @@
     (error* "the username \"checker.ss\" is reserved"))
   (when (get-user-data username)
     (error* "username already exists: `~a'" username))
-  (for-each (lambda (str info)
+  (for ([str extra-fields]
+        [info (get-conf 'extra-fields)])
     (check-field str (cadr info) (car info) (caddr info)))
-            extra-fields (get-conf 'extra-fields))
   (wait-for-lock "+newuser+")
   (log-line "create user: ~a" username)
   (hook 'user-create `([username ,username] [fields ,extra-fields]))
@@ -405,9 +397,9 @@
       (error* "changing information not allowed: ~a" username))
     (when (equal? new-data old-data)
       (error* "no fields changed: ~a" username))
-    (for-each (lambda (str info)
+    (for ([str (cdr new-data)]
+          [info (get-conf 'extra-fields)])
       (check-field str (cadr info) (car info) (caddr info)))
-              (cdr new-data) (get-conf 'extra-fields))
     (log-line "change info for ~a ~s -> ~s" username old-data new-data)
     (unless (equal? (cdr new-data) (cdr old-data)) ; not for password change
       (hook 'user-change `([username ,username]

collects/handin-server/private/hooker.ss

@@ -1,4 +1,5 @@
-(module hooker mzscheme
+#lang scheme/base
+
 (require "config.ss" "logger.ss" "reloadable.ss")
 
 (provide hook)
@@ -14,5 +15,3 @@
         (set! hook-proc (auto-reload-procedure `(file ,(path->string file))
                                                'hook)))
       (hook-proc what (current-session) alist))))
-
-  )

collects/handin-server/private/lock.ss

@@ -1,5 +1,4 @@
-(module lock mzscheme
-  (require mzlib/list)
+#lang scheme/base
 
 (provide wait-for-lock)
 
@@ -61,4 +60,4 @@
                       (handle-evt
                        (req-thread-dead-evt req)
                        (lambda (v) (loop locks (remq req reqs)))))
-                      reqs))))))))
+                    reqs)))))))

collects/handin-server/private/reloadable.ss

@@ -1,11 +1,11 @@
-(module reloadable mzscheme
+#lang scheme/base
 
 (require syntax/moddep "logger.ss")
 
 (provide reload-module)
 (define (reload-module modspec path)
-    ;; the path argument is not needed (could use resolve-module-path here),
-    ;; but its always known when this function is called
+  ;; the path argument is not needed (could use resolve-module-path here), but
+  ;; its always known when this function is called
   (let* ([name ((current-module-name-resolver) modspec #f #f)])
     (log-line "(re)loading module from ~a" modspec)
     (parameterize ([current-module-declare-name name]
@@ -13,16 +13,16 @@
       (namespace-require '(only mzscheme module #%top-interaction))
       (load/use-compiled path))))
 
-  ;; pulls out a value from a module, reloading the module if its source file
-  ;; was modified
+;; pulls out a value from a module, reloading the module if its source file was
+;; modified
 (provide auto-reload-value)
-  (define module-times (make-hash-table 'equal))
+(define module-times (make-hash))
 (define (auto-reload-value modspec valname)
   (let* ([path (resolve-module-path modspec #f)]
-           [last (hash-table-get module-times path #f)]
+         [last (hash-ref module-times path #f)]
          [cur  (file-or-directory-modify-seconds path)])
     (unless (equal? cur last)
-        (hash-table-put! module-times path cur)
+      (hash-set! module-times path cur)
       (reload-module modspec path))
     (dynamic-require modspec valname)))
 
@@ -44,5 +44,3 @@
             (set! proc (dynamic-require modspec procname))))))
     (reload)
     (lambda xs (reload) (apply proc xs))))
-
-  )

collects/handin-server/private/run-status.ss

@@ -1,4 +1,4 @@
-(module run-status mzscheme
+#lang scheme/base
 
 (provide current-run-status-box set-run-status
          current-messenger message)
@@ -17,5 +17,3 @@
 (define (set-run-status s)
   (let ([b (current-run-status-box)])
     (when b (set-box! b s) (message s))))
-
-  )