[uim-commit] r820 - branches/composer/scm

[yamaken at freedesktop.org]

Author: yamaken
Date: 2005-04-06 22:04:52 -0700 (Wed, 06 Apr 2005)
New Revision: 820

Modified:
   branches/composer/scm/util.scm
Log:
* scm/util.scm
  - (define-record): Simplify and Optimize


Modified: branches/composer/scm/util.scm
===================================================================
--- branches/composer/scm/util.scm	2005-04-06 10:44:52 UTC (rev 819)
+++ branches/composer/scm/util.scm	2005-04-07 05:04:52 UTC (rev 820)
@@ -583,33 +583,35 @@
 ;; extensibility (e.g. (nth 2 spec) and so on may be used)
 (define define-record
   (lambda (rec-sym rec-spec)
-    (let ((i 0))
-      (for-each (lambda (spec)
-		  (let* ((index i)
-			 (elem-sym (nth 0 spec))
-			 (default  (nth 1 spec))
-			 (getter-sym (symbolconc rec-sym '- elem-sym))
-			 (getter (lambda (rec)
-				   (nth index rec)))
-			 (setter-sym (symbolconc rec-sym '-set- elem-sym '!))
-			 (setter (lambda (rec val)
-				   (set-car!
-				    (nthcdr index rec)
-				    val))))
-		    (eval (list 'define getter-sym getter)
-			  toplevel-env)
-		    (eval (list 'define setter-sym setter)
-			  toplevel-env)
-		    (set! i (+ i 1))))
-		rec-spec))
+    (for-each (lambda (spec index)
+		(let* ((elem-sym (nth 0 spec))
+		       (default  (nth 1 spec))
+		       (getter-sym (symbolconc rec-sym '- elem-sym))
+		       (getter (lambda (rec)
+				 (nth index rec)))
+		       (setter-sym (symbolconc rec-sym '-set- elem-sym '!))
+		       (setter (lambda (rec val)
+				 (set-car! (nthcdr index rec)
+					   val))))
+		  (eval (list 'define getter-sym getter)
+			toplevel-env)
+		  (eval (list 'define setter-sym setter)
+			toplevel-env)))
+	      rec-spec
+	      (iota (length rec-spec)))
     (let ((creator-sym (symbolconc rec-sym '-new))
-	  (creator (lambda init-lst
-		     (let ((defaults (map cadr rec-spec)))
+	  (creator (let ((defaults (map cadr rec-spec)))
+		     (lambda init-lst
 		       (cond
 			((null? init-lst)
 			 (copy-list defaults))
-			((<= (length init-lst)
-			     (length defaults))
+			;; fast path
+			((= (length init-lst)
+			    (length defaults))
+			 (copy-list init-lst))
+			;; others
+			((< (length init-lst)
+			    (length defaults))
 			 (let* ((rest-defaults (nthcdr (length init-lst)
 						       defaults))
 				(complemented-init-lst (append init-lst