functools

4 files changed, 426 insertions, 80 deletions

diff --git a/modules/language/python/def.scm b/modules/language/python/def.scm
index f0bb161..389e89e 100644
--- a/modules/language/python/def.scm
+++ b/modules/language/python/def.scm
@@ -1,4 +1,5 @@
 (define-module (language python def)
+  #:use-module (oop pf-objects)
   #:use-module (language python for)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-11)
@@ -90,14 +91,15 @@
                            ((k ...) (map car kv))
                            ((s ...) (map ->kw (map car kv)))
                            ((v ...) (map cdr kv)))
-              #`(lambda* (#,@as . l)                     
-                   (call-with-values (lambda () (get-akw l))
-                     (lambda (ww* kw)
-                       (let*-values (((ww* k) (take-1 #,(null? ww-) ww* kw s v))
-                                     ...)
-                         (let ((ww ww*)
-                               (kw (pytonize kw)))
-                           code ...))))))))))))
+	 #`(object-method
+	    (lambda* (#,@as . l)                     
+	      (call-with-values (lambda () (get-akw l))
+		(lambda (ww* kw)
+		  (let*-values (((ww* k) (take-1 #,(null? ww-) ww* kw s v))
+				...)
+		    (let ((ww ww*)
+			  (kw (pytonize kw)))
+		      code ...)))))))))))))
 
 (define-syntax-rule (def (f . args) code ...) (define f (lam args code ...)))
 
diff --git a/modules/language/python/module/functools.scm b/modules/language/python/module/functools.scm
new file mode 100644
index 0000000..0d0311a
--- /dev/null
+++ b/modules/language/python/module/functools.scm
@@ -0,0 +1,314 @@
+
+
+
+(define WRAPPER_ASSIGNMENTS '("__module__" "__name__" "__qualname__" "__doc__"
+			      "__annotations__"))
+
+(define WRAPPER_UPDATES     '("__dict__"))
+
+(def (update_wrapper wrapper
+		     wrapped
+		     (= assigned WRAPPER_ASSIGNMENTS)
+		     (= updated  WRAPPER_UPDATES))
+    "Update a wrapper function to look like the wrapped function
+
+       wrapper is the function to be updated
+       wrapped is the original function
+       assigned is a tuple naming the attributes assigned directly
+       from the wrapped function to the wrapper function (defaults to
+       functools.WRAPPER_ASSIGNMENTS)
+       updated is a tuple naming the attributes of the wrapper that
+       are updated with the corresponding attribute from the wrapped
+       function (defaults to functools.WRAPPER_UPDATES)
+    "
+    (for ((attr : assigned)) ()
+        (try
+	 (lambda ()
+	   (let ((value (getatt wrapped attr)))
+	     (setattr wrapper attr value)))
+	 (#:except AttributeError => values)))
+                
+    (for ((attr : updated)) ()
+	 (py-uppdate (getattr wrapper attr) (getattr wrapped attr (dict))))
+    
+    (set wrapper '__wrapped__ wrapped)
+
+    wrapper)
+
+
+(def (wraps wrapped
+	    (= assigned WRAPPER_ASSIGNMENTS)
+	    (= updated  WRAPPER_UPDATES))
+    "Decorator factory to apply update_wrapper() to a wrapper function
+
+      Returns a decorator that invokes update_wrapper() with the decorated
+      function as the wrapper argument and the arguments to wraps() as the
+      remaining arguments. Default arguments are as for update_wrapper().
+      This is a convenience function to simplify applying partial() to
+      update_wrapper().
+    "
+    (partial update_wrapper #:wrapped wrapped #:assigned assigned
+	     #:updated updated))
+
+;;; TOTAL ORDER ADDITIONS
+(define-syntax-rule (and-not-noteq _gt_from_lt <)
+  (def (_gt_from_lt self other (= NotImplemented NotImplemented))
+       (let ((op_result  (< self other)))
+	 (if (eq? op_result NotImplemented)
+	     op_result
+	     (and (not op_result) (not (equal? self other)))))))
+
+(and-not-noteq _gt_from_lt <)
+
+(define-syntax-rule (or-eq _le_from_lt <)
+  (def (_le_from_lt self other (= NotImplemented NotImplemented))
+       (let ((op_result (< self other)))
+	 (or op_result (equal? self other)))))
+
+(or-eq _le_from_lt <)
+
+(define-syntax-rule (not- _ge_from_lt <)
+  (def (_ge_from_lt self other (= NotImplemented NotImplemented))
+       (let ((op_result (< self other)))
+	 (if (eq? op_result NotImplemented)
+	     op_result
+	     (not op_result)))))
+
+(not- _ge_from_lt <)
+
+(define-syntax-rule (or-not-eq _ge_from_le <=)
+  (def (_ge_from_le self other (= NotImplemented NotImplemented))
+       (let ((op_result (<= self other)))
+	 (if (eq? op_result NotImplemented)
+	     op_result
+	     (or (not op_result) (equal? self other))))))
+(or-not-eq _ge_from_le <=)
+
+(define-syntax-rule (and-noteq _lt_from_le <=)
+  (def (_lt_from_le self other (= NotImplemented NotImplemented))
+       (let ((op_result (<= self other)))
+	 (if (eq? op_result NotImplemented)
+	     op_result
+	     (and op_result (not (equal? self other)))))))
+
+(and-noteq _lt_from_le <=)
+
+(not- _gt_from_le <=)
+
+(and-not-noteq _lt_from_gt >)
+
+(define-syntax-rule (or-eq _ge_from_gt >)
+  (def (_ge_from_gt self other (= NotImplemented NotImplemented))
+       (let ((op_result (> self other)))
+	 (or op_result (equal? self other)))))
+
+(or-eq _ge_from_gt >)
+(not- _le_from_gt >)
+
+(or-not-eq _le_from_ge >=)
+(and-noteq _gt_from_ge >=)
+(not-      _lt_from_ge >=)
+
+(define _convert
+  (let ((h (make-hash-table)))
+    (for-each
+     (lambda (x)
+       (hash-set! h (car x) (cdr x)))
+     `(
+       (__lt__ (__gt__ ,_gt_from_lt)
+               (__le__ ,_le_from_lt)
+               (__ge__ ,_ge_from_lt))
+       (__le__ (__ge__ ,_ge_from_le)
+               (__lt__ ,_lt_from_le)
+               (__gt__ ,_gt_from_le))
+       (__gt__ (__lt__ ,_lt_from_gt)
+               (__ge__ ,_ge_from_gt)
+               (__le__ ,_le_from_gt))
+       (__ge__ (__le__ ,_le_from_ge)
+               (__gt__ ,_gt_from_ge)
+               (__lt__ ,_lt_from_ge))))
+    h))
+
+(define (total_ordering cls)
+  (call-with-values
+      (lambda ()
+	(for ((k v : _convert)) ((mk #f) (mv #f) (l '()))
+	     (if (ref cls k)
+		 (if mk
+		     (if (> k mk)
+			 (values k v   (cons k l))
+			 (values mk mv (cons k l)))
+		     (values k v (list k)))
+		 (values mk mv l))
+	     #:final (values mk mv l)))
+    (lambda (op v roots)
+      (if (not op)
+	  (raise ValueError
+		 "must define at least one ordering operation: < > <= >="))
+      (for ((opname opfunc : v)) ()
+	   (if (not (in opname roots))
+	       (let ((f (lambda (self other) (opfunc self other))))
+		 (set f   '__name__ opname)
+		 (set cls opname    f))))
+
+      cls)))
+
+
+def cmp_to_key(mycmp):
+    """Convert a cmp= function into a key= function"""
+    class K(object):
+        __slots__ = ['obj']
+        def __init__(self, obj):
+            self.obj = obj
+        def __lt__(self, other):
+            return mycmp(self.obj, other.obj) < 0
+        def __gt__(self, other):
+            return mycmp(self.obj, other.obj) > 0
+        def __eq__(self, other):
+            return mycmp(self.obj, other.obj) == 0
+        def __le__(self, other):
+            return mycmp(self.obj, other.obj) <= 0
+        def __ge__(self, other):
+            return mycmp(self.obj, other.obj) >= 0
+        __hash__ = None
+    return K
+(define (cmp_to_key mycmp)
+  (define-python-class-unamed K
+    (define __init__
+      (lambda (self, obj)
+	(set self 'obj obj)))
+    
+    (define __lt__
+      (lambda (self, other)
+	(< (mycmp (ref self 'obj)  (ref other obj)) 0)))
+
+    (define __gt__
+      (lambda (self, other)
+	(> (mycmp (ref self 'obj)  (ref other obj)) 0)))
+
+    (define __eq__
+      (lambda (self, other)
+	(= (mycmp (ref self 'obj)  (ref other obj)) 0)))
+
+    (define __lt__
+      (lambda (self, other)
+	(<= (mycmp (ref self 'obj)  (ref other obj)) 0)))
+
+    (define __gt__
+      (lambda (self, other)
+	(>= (mycmp (ref self 'obj)  (ref other obj)) 0))))
+
+  K)
+
+(define-python-class partial ()
+  (define __init__
+    (lam (self func (* args) (** keywords))
+	 (if (not (callable func))
+	     (raise TypeError "the first argument must be callable"))
+	 
+	 (aif it (ref func 'func)
+	     (begin
+	       (set! args (+ (ref func 'args) args))
+	       (let ((tmpkw (py-copy (ref func 'keywords))))
+		 (py-update mpkw keywords)
+		 (set! keywords tmpkw)
+		 (set func it))))
+	 
+	 (set self 'func     func    )
+	 (set self 'args     args    )
+	 (set self 'keywords keywords)
+	 self))
+
+  (define __call__
+    (lam (self (* args) (** keywords))
+        (let ((newkeywords (py-copy (ref self 'keywords))))
+	  (py-update newkeywords 'keywords)
+	  (py-apply (ref self 'func) (* (ref self 'args) (* args)
+					(** newkeywords))))))
+
+
+  (define __repr__
+    (lambda (self)
+      (let* ((args (ref self 'args '()))
+	     (s1   (if (null? args)
+		       "*"
+		       (format #f "~a~{, ~a~}, *" (car args) (cdr args))))
+	     (kws  (ref self 'keywords (make-hash-table)))
+	     (kw2  (for ((k v : kws)) ((l '()))
+			(cons (format #f "~a=~a" k (repr v)) l)
+			#:final (reverse l)))
+	     (s2   (if (null? kw2)
+		       ""
+		       (format #f ", ~a~{, ~a~}" (car kw2) (cdr kw2)))))
+	(format #f "partial[~a](~a~a)" (repr (ref self 'func)) s1 s2)))))
+
+
+(define-python-class partialmethod ()
+  (define __init__
+    (lam (self func (* args) (** keywords))
+        (if (and (not (callable func)) (not (ref func '__get__)))
+            (raise TypeError (+ (repr func)
+				"is not callable or a descriptor")))
+
+        (if (isinstance func partialmethod)
+            (begin
+	      (set self 'func (ref func 'func))
+	      (set self 'args (+ (ref func 'args) args))
+	      (let ((kws (py-copy (ref func 'keywords))))
+		(py-update kws keywords)
+		(set self 'keywords kws)))
+	    (begin
+	      (set self 'func     func    )
+	      (set self 'args     args    )
+	      (set self 'keywords keywords)))))
+  
+  (define __repr__
+    (lambda (self)
+      (let* ((args (ref self 'args '()))
+	     (s1   (if (null? args)
+		       "*"
+		       (format #f "~a~{, ~a~}, *" (car args) (cdr args))))
+	     (kws  (ref self 'keywords (make-hash-table)))
+	     (kw2  (for ((k v : kws)) ((l '()))
+			(cons (format #f "~a=~a" k (repr v)) l)
+			#:final (reverse l)))
+	     (s2   (if (null? kw2)
+		       ""
+		       (format #f ", ~a~{, ~a~}" (car kw2) (cdr kw2)))))
+	(format #f "partialMethod[~a](~a~a)" (repr (ref self 'func)) s1 s2))))
+
+  (define _make_unbound_method
+    (lambda (self)
+      (def (_method self (* args) (** keywords))
+	(let ((call_keywords (py-copy (ref self 'keywords)))
+	      (call_args     (+ (cls_or_self) (ref self 'args) args)))
+	  (py-update call_keywords keywords)
+	  (py-apply (ref self 'func) (* call_args) (** call_keywords))))
+
+      (set _method '__isabstractmethod__ (ref self '__isabstractmethod__))
+      (set _method '_partialmethod       self)
+      _method))
+
+  (define __get__
+    (lambda (self obj cls)
+      (let* ((func   (ref self 'func))
+	     (get    (ref func '__get__))
+	     (result #f))
+        (if get
+            (let ((new_func  (get obj cls)))
+	      (if (not (eq? new_func func))
+		  (begin
+		    (set! result (py-apply partial new_func
+					   (*  (ref self 'args    ))
+					   (** (ref self 'keywords))))
+		    (aif it (ref new_func '__self__)
+			 (set! result '__self__ it))))))
+	(if (not result)
+            ((ref (ref self '_make_unbound_method) '__get__) obj cls)
+	    result))))
+  
+  (define __isabstractmethod__
+    (property
+     (lambda (self)
+       (ref (ref self 'func) '__isabstractmethod__ #f)))))
+
diff --git a/modules/language/python/procedure.scm b/modules/language/python/procedure.scm
index 55d0b24..51b21d4 100644
--- a/modules/language/python/procedure.scm
+++ b/modules/language/python/procedure.scm
@@ -123,3 +123,9 @@
 				(procedure-properties o))))))
     (pylist-sort! ret)
     ret))
+
+(define (mk-getter-object f)
+  (lambda (obj cls)
+    (if (eq? obj cls)
+	(lambda x (apply f x))
+	(lambda x (apply f obj x)))))
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index 5de0168..655f49c 100644
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -11,7 +11,8 @@
                 call with copy fset fcall put put!
                 pcall pcall! get fset-x pyclass?                
                 def-p-class   mk-p-class   make-p-class
-                define-python-class get-type py-class
+                define-python-class define-python-class-noname
+		get-type py-class
                 object-method class-method static-method
                 py-super-mac py-super py-equal? 
                 *class* *self* pyobject? pytype?
@@ -67,6 +68,48 @@ explicitly tell it to not update etc.
 (name-object <pyf>)
 (name-object <property>)
 
+(define-method (ref (o <procedure>) key . l)
+  (aif it (procedure-property o key)
+       it
+       (if (pair? l)
+	   (car l)
+	   #f)))
+
+(define-method (rawref (o <procedure>) key . l)
+  (aif it (procedure-property o key)
+       it
+       (if (pair? l)
+	   (car l)
+	   #f)))
+
+(define-method (set (o <procedure>) key val)
+  (set-procedure-property! o key val))
+
+(define-method (rawset (o <procedure>) key val)
+  (set-procedure-property! o key val))
+
+(define (mk-getter-object f)
+  (lambda (obj cls)
+    (if (eq? obj cls)
+	(lambda x (apply f x))
+	(lambda x (apply f obj x)))))
+
+(define (mk-getter-class f)				       
+  (lambda (obj cls)
+    (if (eq? obj cls)
+	(lambda x (apply f x))
+	(lambda x (apply f cls x)))))
+
+(define (class-method f)
+  (set f '__get__ (mk-getter-class f)))
+
+(define (object-method f)
+  (set f '__get__ (mk-getter-object f)))
+
+(define (static-method f)
+  (set f '__get__ #f))
+
+
 (define (resolve-method-g g pattern)
   (define (mmatch p pp)
     (if (eq? pp '_)
@@ -208,6 +251,13 @@ explicitly tell it to not update etc.
           x)
         y)))
 
+(define-inlinable (gox obj it)
+  (let ((class (fluid-ref *location*)))
+    (aif it (rawref it '__get__)
+	 (it obj class)
+	 it)))
+
+(define *location* (make-fluid #f))
 (define-syntax-rule (mrefx x key l)
   (let ()
     (define (end)
@@ -220,15 +270,15 @@ explicitly tell it to not update etc.
         (if (pair? li)
             (let ((p (car li)))
               (cif (it h) (key p)
-                   it
+                   (begin (fluid-set! *location* p) it)
 		   (lp (cdr li))))
             fail)))
   
     (cif (it h) (key x)
-         it
+         (begin (fluid-set! *location* x) it)
          (hif cl ('__class__ h)
               (cif (it h) (key cl)
-                   it
+                   (begin (fluid-set! *location* cl) it)
                    (hif p ('__mro__ h)
                         (let ((r (parents p)))
                           (if (eq? r fail)
@@ -237,8 +287,6 @@ explicitly tell it to not update etc.
                         (end)))
               (end)))))
 
-(define *refkind* (make-fluid 'object))
-
 (define-method (find-in-class (klass <p>) key fail)
   (hash-ref (slot-ref klass 'h) key fail))
 
@@ -250,12 +298,12 @@ explicitly tell it to not update etc.
 
 (define-syntax-rule (find-in-class-and-parents klass key fail)
   (kif r (find-in-class klass key fail)
-       r
+       (begin (fluid-set! *location* klass) r)
        (aif parents (find-in-class klass '__mro__ #f)
 	    (let lp ((parents parents))
 	      (if (pair? parents)
 		  (kif r (find-in-class (car parents) key fail)
-		       r
+		       (begin (fluid-set! *location* (car parents)) r)
 		       (lp (cdr parents)))
 		  fail))
 	    fail)))
@@ -263,11 +311,10 @@ explicitly tell it to not update etc.
 (define-syntax-rule (mrefx klass key l)
   (let ()
     (define (end) (if (pair? l) (car l) #f))
-    (fluid-set! *refkind* 'object)
+    (fluid-set! *location* klass)
     (kif it (find-in-class klass key fail)
 	 it
 	 (begin
-	   (fluid-set! *refkind* 'class)
 	   (aif klass (find-in-class klass '__class__ #f)
 		(kif it (find-in-class-and-parents klass key fail)
 		     it
@@ -291,40 +338,32 @@ explicitly tell it to not update etc.
 	    (f (if g
 		   (if (eq? g #t)
 		       (aif it (mrefx xx '__getattribute__ '())
-			    (begin
-			      (mset xx '__fget__ it it)
-			      it)
+			    (let ((f (gox xx it)))
+			      (rawset xx '__fget__ it)
+			      f)			    
 			    (begin
 			      (if (mc?)
-				  (mset xx '__fget__ it it))
+				  (rawset xx '__fget__ #f))
 			      #f))
 		       g)
 		   #f)))
        (if (or (not f) (eq? f not-implemented))
-	   (mrefx xx key l)
+	   (gox xx (mrefx xx key l))
 	   (catch #t
 		  (lambda ()
-		    (make-variable
-		     ((f xx (fluid-ref *refkind*)) key)))
+		    (f key))
 		  (lambda x
-		    (mrefx xx key l))))))))
+		    (gox xx (mrefx xx key l)))))))))
 
 
 (define-syntax-rule (mref x key l)
   (let ((xx x))
-    (let ((res (mrefx xx key l)))
-      (if (and (not (struct? res)) (procedure? res))
-	  (res xx (fluid-ref *refkind*))
-	  res))))
+    (mrefx xx key l)))
 
 (define-syntax-rule (mref-py x key l)
   (let ((xx x))
     (let ((res (mrefx-py xx key l)))
-      (if (variable? res)
-	  (variable-ref res)
-	  (if (and (not (struct? res)) (procedure? res))
-	      (res xx (fluid-ref *refkind*))
-	      res)))))
+      res)))
 
 (define-method (ref x key . l) (if (pair? l) (car l) #f))
 (define-method (ref (x <pf> )  key . l) (mref     x key l))
@@ -332,6 +371,7 @@ explicitly tell it to not update etc.
 (define-method (ref (x <pyf>)  key . l) (mref-py  x key l))
 (define-method (ref (x <py> )  key . l) (mref-py  x key l))
 
+(define-method (rawref x key . l) (if (pair? l) (car l) #f))
 (define-method (rawref (x <pf> )  key . l) (mref     x key l))
 (define-method (rawref (x <p>  )  key . l) (mref     x key l))
 
@@ -367,7 +407,7 @@ explicitly tell it to not update etc.
     (values)))
 
 ;; on object x add a binding that key -> val
-(define-method (mset (x <pf>) key rval val)
+(define-method (mset (x <pf>) key val)
   (let ((h (slot-ref x 'h))
         (s (slot-ref x 'size))
         (n (slot-ref x 'n)))
@@ -382,7 +422,7 @@ explicitly tell it to not update etc.
 
 (define (pkh h) (hash-for-each (lambda x (pk x)) h) h)
 
-(define-method (mset (x <p>) key rval val)
+(define-method (mset (x <p>) key val)
   (begin
     (hash-set! (slot-ref x 'h) key val)
     (values)))
@@ -390,7 +430,7 @@ explicitly tell it to not update etc.
 (define *make-class* (make-fluid #f))
 (define (mc?) (not (fluid-ref *make-class*)))
 
-(define-syntax-rule (mset-py x key rval val)
+(define-syntax-rule (mset-py x key val)
   (let* ((xx x)
 	 (v  (mref xx key (list fail))))
     (if (or (eq? v fail)
@@ -399,34 +439,25 @@ explicitly tell it to not update etc.
 	(let* ((g (mrefx xx '__fset__ '(#t)))
 	       (f (if g
 		      (if (eq? g #t)
-			  (aif it (mrefx xx '__setattr__ '())
+			  (aif it (rawref xx '__setattr__)
 			       (begin
-				 (mset xx '__fset__ it it)
+				 (rawset xx '__fset__ it)
 				 it)
 			       (begin
 				 (if (mc?)
-				     (mset xx '__fset__ it it))
+				     (rawset xx '__fset__ it))
 				 #f))
 			  g)
 		      #f)))
 	  (if (or (eq? f not-implemented) (not f))
-	      (mset xx key val val)              
+	      (mset xx key val)              
 	      (catch #t
-	        (lambda () ((f xx (fluid-ref *refkind*)) key rval))
-		(lambda x (mset xx key val val)))))
+	        (lambda () (f key val))
+		(lambda q  (mset xx key val)))))
 	((slot-ref v 'set) xx val))))
 
 (define-syntax-rule (mklam (mset a ...) val)
-  (if (and (procedure? val)
-           (not (pyclass? val))
-           (not (pytype?  val))
-           (if (is-a? val <p>)
-               (ref val '__call__)
-               #t))
-      (if (procedure-property val 'py-special)
-          (mset a ... val val)
-          (mset a ... val (object-method val)))
-      (mset a ... val val)))
+  (mset a ... val))
 
 (define-method (set (x <pf>)  key val) (mklam (mset     x key) val))
 (define-method (set (x <p>)   key val) (mklam (mset     x key) val))
@@ -781,6 +812,21 @@ explicitly tell it to not update etc.
 	    (name-object name)
 	    name))))))
 
+(define-syntax mk-p-class-noname
+  (lambda (x)
+    (syntax-case x ()
+      ((_ name parents (ddef dname dval) ...)
+       #'(let ()
+	   (define name 
+	     (letruc ((dname dval) ...)
+		     (make-p-class 'name
+				   parents
+				   (lambda (dict)
+				     (pylist-set! dict 'dname dname)
+				     ...
+				     (values)))))
+	   name)))))
+
 (define-syntax-rule (def-p-class name . l)
   (define name (mk-p-class name . l)))
 
@@ -835,6 +881,10 @@ explicitly tell it to not update etc.
 (define-syntax-rule (define-python-class name (parents ...) code ...)
   (define name (mk-p-class name (arglist->pkw (list parents ...)) code ...)))
 
+(define-syntax-rule (define-pythonc-lass-noname name (parents ...) code ...)
+  (define name (mk-p-class-noname name (arglist->pkw (list parents ...))
+				  code ...)))
+
 
 (define-syntax make-python-class
   (lambda (x)
@@ -862,32 +912,6 @@ explicitly tell it to not update etc.
   (set-procedure-property! f 'py-special tag)
   f)
 
-(define (object-method f)
-  (letrec ((self
-            (mark-fkn 'object
-                      (lambda (x kind)
-			(if (eq? kind 'object)
-			    f
-			    (lambda z (apply f x z)))))))
-    self))
-
-(define (class-method f)
-  (letrec ((self
-            (mark-fkn 'class
-              (lambda (x kind)
-		(if (eq? kind 'object)
-		    (let ((klass (ref x '__class__)))
-		      (lambda z (apply f klass z)))
-		    (lambda z (apply f x z)))))))
-    self))
-
-(define (static-method f)
-  (letrec ((self
-            (mark-fkn 'static
-                      (lambda (x kind) f))))
-    self))
-
-        
 (define-syntax-parameter
   *class* (lambda (x) (error "*class* not parameterized")))
 (define-syntax-parameter