www

commit 820a452dbf29886f3b651d449f2e2cdab46fcc71
parent 5277544ada79e632afb328dcdf5e414e579bbc73
Author: Bertrand BRUN <bertrand.brun@me.com>
Date:   Fri,  5 Nov 2010 11:34:50 +0100

Ajout du curry pour manger

Diffstat:
M
lisp2li.lisp
 | 
18
++++++++++++++----
M
meval.lisp
 | 
1
-
M
util.lisp
 | 
29
+++++++++++++++++++++++++++++

3 files changed, 43 insertions(+), 5 deletions(-)
diff --git a/lisp2li.lisp b/lisp2li.lisp
@@ -40,7 +40,7 @@ par le compilateur et par l’interpréteur"
                (lisp2li (third expr) env-var env-fun)
                (lisp2li (fourth expr) env-var env-fun)))
 	;; quotes
-        ((eq 'quote (car expr)) 
+        ((eq 'quote (car expr))
          (cons :lit (second expr)))
         ;; defun
 	((eq 'defun (car expr)) 
@@ -62,8 +62,8 @@ par le compilateur et par l’interpréteur"
                (body (cddr expr)))
            (lisp2li `((lambda ,(mapcar #'car bindings)
                ,@body)
-               ,@(mapcar #'cadr bindings)) env-var env-fun)))
-	;; let*
+                      ,@(mapcar #'cadr bindings)) env-var env-fun)))
+        ;; let*
         ((eq 'let* (car expr))
          (let ((bindings (cadr expr))
                (body (caddr expr)))
@@ -72,6 +72,16 @@ par le compilateur et par l’interpréteur"
                       `(let (,(car bindings))
                          (let* ,(cdr bindings)
                            ,body))) env-var env-fun)))
+        ;; labels
+        ((eq 'labels (car expr))
+         (let ((bindings (cadr expr))
+               (body (cddr expr)))
+           (lisp2li `((lambda ,(mapcar #'car bindings)
+                        ,@body)
+                      ,@(mapcar #'cadr bindings)) env-var env-fun)))
+        ;; `
+        ((eq '` (car expr))
+         (print "Ca marche"))
 	;; progn
 	((eq 'progn (car expr))
 	 (cons :progn (map-lisp2li (cdr expr) env-var env-fun)))
@@ -86,7 +96,7 @@ par le compilateur et par l’interpréteur"
         ))
 
 (defun map-lisp2li (expr env-var env-fun)
-  (mapcar (lambda (x) (lisp2li x env-var env-fun)) expr))
+  (mapcar (curry #'lisp2li :skip env-var env-fun) expr))
 
 (defun map-lisp2li-let (expr env)
   (mapcar (lambda (x) (add-binding env (car x) (lisp2li (cadr x) env))) (cadr expr)))
diff --git a/meval.lisp b/meval.lisp
@@ -17,7 +17,6 @@
 
 (defun map-meval (list env)
   (mapcar (lambda (x) (meval x env)) list))
-
 (defun foo (x) x)
 
 ;; Test unitaire
diff --git a/util.lisp b/util.lisp
@@ -34,3 +34,31 @@
       t
       (and (consp l)
            (n-consp (- n 1) (cdr l)))))
+
+(defun range (a &optional b)
+  (cond ((null b) (range 0 a))
+        ((> a b) (loop for i from a above (- b 1) collect i))
+        (T (loop for i from a to b collect i))))
+
+(defun shift (n l)
+  (if (<= n 0)
+      l
+    (shift (- n 1) (cdr l))))
+
+(defmacro curry (fun &rest params)
+  `(lambda (&rest actual-params)
+     (apply ,fun
+            ,@(mapcar (lambda (x n)
+                        (if (eq :skip x)
+                            `(nth ,(- n 1) actual-params)
+                          x))
+                      params
+                      (range (length params)))
+            (shift ,(count-if (lambda (x) (eq x :skip)) params)
+                   actual-params))))
+
+(defun foo (x y z) (list x y z))
+(defvar cfoo nil)
+(setq cfoo (curry #'foo 1 2))
+(defvar cfoo2 nil)
+(setq cfoo2 (curry #'foo :skip 2))
+\ No newline at end of file