Listing 5. Arrange files into disk-sized directories

#!/usr/bin/scm -f
;; load various SCM/SLIB extensions.
(require 'sort)
(require 'i/o-extensions)
(require 'rev2-procedures)
(require 'common-list-functions)
;; program constants
(define *max-dir-size* (* 1400 1024))
(define *new-dir-mode* #o755)
;; globals
(define *dirlist* '())         ;list of dest. directories
(define *splist*  '())         ;list of files & sizes
(define *dirnum*    1)
;; main function
;;
(define (main argv)
   (arrange (cdddr argv)))
;; arranges the files into directories in memory
;; and then does it on disk
(define (arrange files)
   (for-each add-file
         (sort (filelist->splist files) file-smaller?)) (for-each move-files-into-directory *dirlist*))
;; given a dirlist, create the directories and move ;; the files into their respective directories.
;;
(define (move-files-into-directory dir)
   (let ((dirname (gendirname)))
(mkdir dirname *new-dir-mode*)
(for-each (lambda (file) (rename-file (car file)
(string-append dirname "/" (car file))))
                  dir)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; secondary functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; add a file to a directory.
;; create a new directory and add it to the global ;; list if necessary.
;; if the file is larger than the maximum
;; directory size,
;; simply discard it.
;;
(define (add-file file)
   (let ((dir (find-dir file)))
      (if dir
         (nconc dir (list file))
(if (< (cadr file) *max-dir-size*)
;; discard file if too large
(set! *dirlist* (append *dirlist*

      (new-dir file)))))
      ))
;; find a directory that can hold this file.  if none do, return #f ;;
(define (find-dir file)
   (find-if (lambda (dir)
               (file-fits? file dir))
               *dirlist*))
;; given a list of filenames, return a list of
;; lists wherein each sublist will contain the
;; filename and the file size i.e.
;; (("/etc/passwd" 1005) ("/etc/group" 299))
;;
(define (filelist->splist fl)
   (map (lambda (file)
            (list file (file-size file)))
         fl))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; helper functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; generate the next directory name in the sequence
(define (gendirname)
(let ((name (string-append "dir" (number->string *dirnum*))))
      (set! *dirnum* (+ *dirnum* 1))
      name))
;; create a new directory containing file
;;
(define (new-dir file)
   (list (list file)))
;; return #t if file fits into dir (with a
;; directory size of *max-dir-size*)
;;
(define (file-fits? file dir)
( (+ (dir-size dir) (cadr file)) *max-dir-size*))
;; return #t if file1 is smaller than file2
(define (file-smaller? file1 file2)
   (>= (cadr file1) (cadr file2)))
;; given a directory, return its size by simply
;; summing all the file sizes
;;
(define (dir-size dir)
   (apply + (map cadr dir)))
;; return the seventh element of the stat array
;; (the size)
(define (file-size file)
   (vector-ref (stat file) 7))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; top-level main program invocation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(main *argv*)
(exit)