remove database warnings

Makefile

@@ -14,4 +14,4 @@ test:
 	csc test-database.scm
 	csc -s -J parse.scm
 	csc test-parse.scm
-	./test-util && ./test-database && ./test-parse && echo "All tests passed."
+	./test-util && ./test-database && ./test-parse

test-database.scm

@@ -6,43 +6,43 @@
   (import database)
 
   (test-group "database"
-	      (test '((test . ((test-key . 3)))) (begin (set! *database* '())
+	      (test '((test . ((test-key . 3)))) (begin (database-null)
 							(database-set 'test 'test-key 3)
 							*database*))
-	      (test 3 (begin (set! *database* '())
+	      (test 3 (begin (database-null)
 			     (database-set 'test 'test-key 3)
 			     (database-get 'test 'test-key #f)))
-	      (test '((test . ((test-key . 3)))) (begin (set! *database* '())
+	      (test '((test . ((test-key . 3)))) (begin (database-null)
 							(database-set 'test 'test-key 3)
 							(database-save "test.sav")
-							(set! *database* '())
+							(database-null)
 							(database-load "test.sav")))
-	      (test '() (begin (set! *database* '())
+	      (test '() (begin (database-null)
 			       (database-set 'test 'test-key 3)
 			       (database-remove 'test)
 			       *database*))
-	      (test '(test) (begin (set! *database* '())
+	      (test '(test) (begin (database-null)
 				   (database-set 'test 'test-key 3)
 				   (get-all-objects)))
 	      (test-group "object-exists?"
-			  (test #t (begin (set! *database* '())
+			  (test #t (begin (database-null)
 					  (database-set 'test 'test-key 3)
 					  (object-exists? 'test)))
-			  (test #f (begin (set! *database* '())
+			  (test #f (begin (database-null)
 					  (object-exists? 'test))))
 	      (test-group "has-property?"
-			  (test #t (begin (set! *database* '())
+			  (test #t (begin (database-null)
 					  (database-set 'test 'test-key 3)
 					  (has-property? 'test 'test-key)))
-			  (test #f (begin (set! *database* '())
+			  (test #f (begin (database-null)
 					  (database-set 'test 'test-key 3)
 					  (has-property? 'test 'nosuch-key))))
 	      (test-group "toggle-flag"
-			  (test #t (begin (set! *database* '())
+			  (test #t (begin (database-null)
 					  (database-set 'test 'test-key #f)
 					  (toggle-flag 'test 'test-key)
 					  (database-get 'test 'test-key #f)))
-			  (test #f (begin (set! *database* '())
+			  (test #f (begin (database-null)
 					  (database-set 'test 'test-key #t)
 					  (toggle-flag 'test 'test-key)
 					  (database-get 'test 'test-key #t))))))

world.scm

@@ -1,3 +1,9 @@
+;;; Functions modeling a standard text adventure world.
+;;; Location is modeled as containment, movement is modeled via passage nodes
+;;; that hold properties and descriptions for a given exit.
+;;; Global properties are held in the player object YOU, which also acts as
+;;; the default avatar object.
+
 (module world (adventure create-object move-object add-alias set-hidden toggle-fixed set-enter-message set-destination get-container print-room-description)
   (import scheme)
   (import chicken.base)
@@ -10,6 +16,9 @@
   (import database)
   (import io)
 
+
+  ;; The canonical name of a given cardinal direction
+  ;; and it's aliases.
   (define +cardinal-sets+
     '((north n)
       (northeast ne north-east)
@@ -22,6 +31,7 @@
       (up u)
       (down d)))
 
+  ;; The mirror direction for a given direction.
   (define +cardinal-opposites+
     '((north . south)
       (northeast . southwest)
@@ -34,17 +44,34 @@
       (up . down)
       (down . up)))
 
+  ;; Main game loop exit condition.
   (define *exit-adventure* #f)
 
+  (define-syntax get-set-define
+    (er-macro-transformer
+     (lambda (exp rename compare)
+       (let ((flag (car exp)))
+	 (begin
+	   `(define (,(string->symbol (string-append (symbol->string flag) "-get")) object value)
+	      (database-get object ,flag value))
+	   `(define (,(string->symbol (string-append (symbol->string flag) "-set")) object value)
+	      (database-set object ,flag value)))))))
+
+  (get-set-define test-value)
+
+  ;; Set the name of an object.
   (define (set-name object name)
     (database-set object 'name name))
 
+  ;; Set the description of an object.
   (define (set-description object description)
     (database-set object 'description description))
 
+  ;; Get the name of an object.
   (define (get-name object)
     (database-get object 'name (symbol->string object)))
 
+  ;; Get the description of an object.
   (define (get-description object)
     (database-get object 'description "You see the swirling void of creation."))
   
@@ -92,7 +119,7 @@
     (database-set object 'fixed value))
 
   (define (get-fixed object value)
-    (database-get object 'hidden #f))
+    (database-get object 'fixed #f))
 
   (define (get-put-message object)
     (database-get object 'put-message "You put the ~a into the ~a."))
@@ -100,7 +127,7 @@
   ;; Is development mode enabled?
 
   (define (devmode-enabled?)
-    (has-property? 'you 'devmode))
+    (database-get 'you 'devmode #f))
 
   (define (toggle-devmode)
     (toggle-flag 'you 'devmode))
@@ -108,7 +135,7 @@
   ;; Is an object fixed in place (e.g. cannot be picked up?)
 
   (define (fixed? object)
-    (has-property? object 'fixed))
+    (database-get object 'fixed #f))
 
   (define (toggle-fixed object)
     (toggle-flag object 'fixed))
@@ -153,7 +180,13 @@
     (fmt #t (dsp (wrap-lines (get-description room))))
     (newline)
     (display "You see: ")
-    (map (lambda (n) (if (not (get-hidden n)) (begin (display (get-name n)) (display " ") (if (devmode-enabled?) (begin (display (set-text '(bold fg-green) (string-append "[" (symbol->string n) "] ")))))))) (remove (curry eq? 'you) (get-contents room)))
+    (map (lambda (n)
+	   (if (not (get-hidden n))
+	       (begin
+		 (display (get-name n))
+		 (display " ")
+		 (if (devmode-enabled?)
+		     (display (set-text '(bold fg-green) (string-append "[" (symbol->string n) "] "))))))) (remove (curry eq? 'you) (get-contents room)))
     (newline))
 
   (define (do-command-enter tag)