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)