Import des modifications de la branche compilation-georges.

TODO-Liste

@@ -2,7 +2,8 @@ TODO :
 - Ajouter la fonction map-case-analysis
 - Changer les <signal> par les fonctions warn (warning ?) ou error selon le cas d'utilisation.
 - Remplacer les ";; cas machin" par le code effectif.
-
+- copy-all doit gérer les structures circulaires
+- modifier run-tests pour qu'il renvoie la syntaxe d'un appel de macro qui ferait les let des deftestvar correctement (sans appel à eval).
 
 Questions :
 - Le prof a dit qu'on ne devait pas gérer le tas, donc pas d'affectations (setf, ...).

implementation/compilation.lisp

@@ -0,0 +1,138 @@
+(load "match")
+(load "util")
+(load "implementation/lisp2cli")
+
+(defvar asm-fixnum-size 32)
+(defvar asm-max-fixnum (expt 2 asm-fixnum-size))
+(defun type-number (type)
+  (position type '(fixnum bignum symbol string cons nil)))
+(defvar label-ctr 0)
+
+(defmacro fasm (&rest stuff)
+  `(format nil ,@stuff))
+(defun db-type (type)
+  (fasm "db ~a" (type-number type)))
+
+;; My-compile
+
+(defvar result-asm nil)
+(defvar sections '(data code))
+
+(defun real-asm-block (section label body)
+  (when (not (member section sections))
+    (error "Section assembleur inconnue : ~w" section))
+  (push (format nil "section .~w" section) result-asm)
+  (push (format nil "~a:" label) result-asm)
+  (mapcar (lambda (x) (push x result-asm)) body)
+  label)
+
+(defun asm-block (section label-base &rest body)
+    (real-asm-block
+     section
+     (format nil "~a-~a" label-base (incf label-ctr))
+     body))
+
+(defvar asm-once nil)
+(defun asm-once (section label &rest body)
+  (unless (member label asm-once :test #'string-equal)
+    (push label asm-once)
+    (real-asm-block section label body))
+  label)
+
+(defmacro my-compile (expr)
+  `(progn (setq result-asm nil)
+          (setq asm-once nil)
+          (my-compile-1 `(:main ,(lisp2cli ',expr)))
+          (format nil "~&~{~%~a~}" (flatten (reverse result-asm)))))
+
+;;; Règles de compilation
+
+(defmatch my-compile-1)
+
+;; fixnum
+(defmatch my-compile-1 (:nil :const :num . (? numberp (< x asm-max-fixnum)))
+  (asm-block 'data "fixnum-constant"
+             (db-type 'fixnum)
+             (fasm "db ~a" num)))
+
+;; bignum
+(defmatch my-compile-1 (:nil :const :num . (? numberp (>= x asm-max-fixnum)))
+  (asm-block 'data "bignum-constant"
+             (db-type 'bignum)
+             (let ((lst (split-bytes num asm-fixnum-size)))
+               (fasm "~{~&db ~a~}" (cons (length lst) lst)))))
+
+;; string
+(defmatch my-compile-1 (:nil :const :str . (? stringp))
+  (asm-block 'data "string-constant"
+             (db-type 'string)
+             (fasm "db ~a" (length str))
+             (fasm "~{~&db ~a~}" (map 'list #'char-code str))))
+
+;; symbol
+(defmatch my-compile-1 (:nil :const :sym . (? symbolp))
+  (asm-once 'data (format nil "symbol-~w" sym)
+             (db-type 'symbol)
+             (fasm "db @~a" (my-compile-1 (string sym)))))
+
+;; cons
+(defmatch my-compile-1 (:nil :const . (:car _ :cdr . _))
+  (asm-block 'data "cons-cell-constant"
+             (db-type 'cons)
+             (fasm "db @~a" (my-compile-1 `(:const . ,car)))
+             (fasm "db @~a" (my-compile-1 `(:const . ,cdr)))))
+
+(defun compile-get-val (cli)
+  (if (match (:nil :const . _) cli)
+      (list (fasm "load @~a r0" (my-compile-1 cli))
+            (fasm "push r0"))
+      (list (my-compile-1 cli)
+            (fasm "push r0"))))
+
+;; call
+(defmatch my-compile-1 (:nil :call :name _ :params . _)
+  (list
+   (mapcar #'compile-get-val params)
+   (fasm "push ~a" (length params))
+   (fasm "jsr function-~a" name)))
+
+;; main
+(defmatch my-compile-1 (:nil :main :body _*)
+  (asm-once 'code "main"
+            (mapcar #'my-compile-1 body)))
+
+;;; Exemples
+
+(my-compile '(1 2 3))
+
+(my-compile 3)
+;; section .data
+;; fixnum-constant-1
+;;   db 0
+;;   db 3
+
+(my-compile (+ 2 3))
+;; =>
+;; section .data
+;; fixnum-constant-1:
+;;   db 1
+;;   db 2
+;; section .data
+;; fixnum-constant-2:
+;;   db 1
+;;   db 3
+;; section .code
+;; code-1:
+;;   load @global-1 r0
+;;   push r0
+;;   load @global-2 r0
+;;   push r0
+;;   push 2
+;;   jsr @fn-+
+;;   retn
+;; section .text
+;; :fn-+
+;;   pop r1
+;;   pop r0
+;;   add r1 r0
+;;   retn

implementation/lisp2cli.lisp

@@ -0,0 +1,374 @@
+;; lisp2li simpliste pour le compilateur. On fusionnera les deux plus tard.
+
+(defmatch lisp2cli)
+
+(defmatch lisp2cli (:num . (? numberp)) `(:const . ,num))
+(defmatch lisp2cli (:str . (? stringp)) `(:const . ,str))
+(defmatch lisp2cli (quote :val _)       `(:const . ,val))
+(defmatch lisp2cli ()                   `(:const . nil))
+(defmatch lisp2cli (let ((:name $ :value _)*) :body _*)
+  `(:let ,name ,value ,body))
+(defmatch lisp2cli (:name _ :params _*) `(:call ,name ,@(mapcar #'lisp2cli params)))
+(defmatch lisp2cli (:x . _)             (error "Lisp2cli ne sait pas gérer : ~w" x))
+
+
+#|
+
+;; Formes pouvant créer des variables capturables :
+lambda
+let
+let* // let imbriqués
+// progv // compliqué, pas très utile
+flet // let pour les fonctions
+labels // letrec pour les fonctions
+macrolet // letrec pour les macros
+// symbol-macrolet // compliqué, pas très utile
+
+;; Formes pouvant capturer des variables :
+lambda
+defun => lambda
+
+;; Comportement des variables globales et spéciales
+- une variable qui n'est pas attachée lexicalement est globale
+- une variable qui est déclarée speciale dans le cadre d'un let, defun, etc., est
+  modifiée globallement par sa nouvelle valeur (celle du let / paramètre), puis
+  sa valeur est restaurée à la fin du let / defun / ...
+- une variable qui est globalement spéciale (comme c'est le cas pour les variables defvar)
+  a une seule valeur partagée entre toutes ses utilisations. Autrement dit, partout
+  où cette variable est lue ou modifiée, c'est la même valeur qui est utilisée.
+
+(defvar x val)
+=> (progn (proclaim '(special x))
+          (unless (boundp 'x)
+            (setq x val)))
+(boundp var)
+=> t si var _globale_ est bound (on s'en fiche de son état lexical).
+
+;; Comportement des closures
+Lorsqu'on fait une closure (à l'exécution donc), elle capture *toutes* les variables capturables de l'environnement.
+Les variables capturées ont ensuite leur valeur partagée entre les différentes closures qui les utilisent et "l'extérieur" (le lieu de déclaration initial des variables).
+Exemple :
+(defun introspect () nil)
+(defun make-closure (initial)
+  (let ((a 1) (b 2) (c 3))
+    (let ((closure-incf (lambda () (incf initial)))
+          (closure-return (lambda () (introspect) initial)))
+      (print initial)
+      (funcall closure-incf)
+      (print initial) ;; l'extérieur partage la même valeur
+      (cons closure-incf closure-return))))
+(setq cl1 (make-closure 1))
+=> 1
+=> 2
+=> (#<closure...> . #<closure...>)
+(setq cl42 (make-closure 42))
+=> 42
+=> 43
+=> (#<closure...> . #<closure...>)
+;; les valeurs sont partagées entre les closures créées sur les mêmes instances de variables
+(funcall (car cl1))
+=> 3
+(funcall (cdr cl1))
+=> 3
+;; mais pas entre des closures créées à différents moments
+(funcall (cdr cl42))
+=> 43
+
+Le comportement des fonctions et des macros expliqué ci-dessous permet de prouver que la capture s'effectue sur toutes les variables et non pas seulement celles qui paraissent être accessibles :
+(defmacro introspect-closure (get-variable closure)
+  `(progn (defmacro introspect () '(print ,get-variable))
+          (funcall ,closure)))
+(introspect-closure a (cdr cl1))
+=> 1 ;; (print a)
+=> 3
+(introspect-closure b (cdr cl1))
+=> 2 ;; (print b)
+=> 3
+(introspect-closure c (cdr cl1))
+=> 3 ;; (print c)
+=> 3
+(introspect-closure initial (cdr cl1))
+=> 3 ;; (print intitial)
+=> 3
+
+Un autre moyen de le vérifier est de mettre dans le let ((a 1) (b 2) (c 3)) un autre variable, non utilisée, qui est associée à une très grosse liste (un million d'éléments).
+Après avoir créé une vingtaine de closures, on voit dans "top" que clisp occupe environ 90 Mo de RAM, alors qu'auparavent il n'en occupait que très peu.
+Pourtant ces listes d'un million d'éléments semblent inaccessibles, sauf par notre trucage introspect-closure.
+
+;; Comportement des fonctions et des macros
+Si une macro est rencontrée, elle est expansée
+Si un appel de fonction est rencontré, la fonction est appellée telle qu'elle
+Si une fonction est redéfinie en tant que macro, tous les appels de fonction qui lui correspondent sont transformés en appels de macro (expansion à la volée). On peut alors redéfinir la  macro en macro ou en fonction, au choix, plusieurs fois, les appels suivent "intuitivement". (Ça existe encore ça l'intuition ?)
+Si une macro "rencontrée initialement" est redéfinie en tant que fonction, les appels qui ont déjà été "expansés initialement" ne sont pas redéfinis.
+Dans la structure suivante, la règle du "rencontrée initialement" est bien appliquée, la macro n'est pas ré-expansée :
+(defmacro mcr (x) `(list ',x 'y))
+(defun bar-maker () (defun bar () (mcr a)))
+(bar-maker)
+(bar)
+=> (a y)
+(defmacro mcr (x) `(list ',x 'z))
+(bar)
+=> (a y)
+(bar-maker)
+(bar)
+=> (a y)
+
+;; Décision
+
+Pour des raisons de santé mentale, d'efficacité et d'alignement des planètes, nous ne supporterons pas la redéfinition de fonctions en tant que macros.
+De même, si une macro est utilisée avant sa définition, elle ne sera pas expansée, et déclenchera probablement une erreur "undefined function".
+Et pour simplifier la compilation, toutes les définitions de macros seront prises en compte,
+qu'elles soient à l'intérieur d'un if, d'un defun, d'un let... sans prendre en compte leur environnement.
+
+;; Fonctionnement des block et tagbody
+Les noms de blocs sont un peu comme des variables, ils sont capturés par les closures.
+Ainsi, dans l'exemple suivant, lorsque le (return-from a) est apellé, on sort directement
+du premier bloc a dans la pile d'appels.
+
+(defun foo (fn n)
+  (format t "~&foo ~a ~a" n fn)
+  (block a
+    (bar (if fn fn (lambda (x)
+                     (format t "~&lambda ~a" x)
+                     (if (<= x 0) (return-from a 42))))
+         n))
+  (format t "~&foo2"))
+
+(defun bar (fn n)
+  (format t "~&bar ~a ~a" n fn)
+  (funcall fn n)
+  (foo fn (- n 1))
+  (format t "~&bar2"))
+
+;; Choix d'implémentation des block / return-from, tagbody / go, catch / throw
+
+Lorsqu'on rentre dans un block, on met sur la pile un marqueur spécial avec un pointeur vers un objet créé à l'exécution.
+Les return-from <nom> qui sont accessibles lexicalement sont remplacés par un (unwind <l'objet>)
+Unwind remonte la pile jusqu'à trouver le marqueur spécial, tout en exécutant les unwind-protect éventuels.
+Si unwind ne trouve pas le marqueur et arrive en haut de la pile, il signale une erreur et termine le programme.
+Sinon, l'exécution reprend après le block.
+Le traitement de tagbody/go est similaire pour sortir d'un tag, puis on jmp directement sur le tag de destination (vu qu'il est au même niveau).
+Le traitement de catch/throw est similaire, sauf que le pointeur est simplement un pointeur vers l'objet utilisé pour le catch / throw.
+À noter que la liaison lexicale pour le block et le tagbody est à effectuer avant de sortir éventuellement des lambdas anonymes de leur fonction englobante.
+(comme la liaison lexicale ne s'effectue pas sur des variables, cette transformation ne présèrverait pas la liaison).
+Cette étape doit s'effectuer après l'expansion de macros, sinon on risque de louper des block / return-from / ... .
+
+;; Choix d'implémentation des closures :
+Lorsqu'une variable est capturée, on ne peut pas copier directement l'adresse dans le tas de sa valeur pour pouvoir la manipuler,
+car il se peut que l'on doive déplacer la valeur si on souhaite la remplacer par quelque chose de plus gros (par ex. remplacer un nombre par une string).
+On est donc obligé d'avoir un pointeur d'indirection supplémentaire, de taille fixe, qui ne sera pas déplacé.
+Ce pointeur est ce qu'on appellera la closure-cell.
+
+Lorsqu'on rencontre un binding d'une variable (let, labels, lambda, ...), on regarde si elle est capturée à l'intérieur
+du corps du special-form qui effectue la liaison.
+Si c'est le cas, on crée une closure-cell, qui contient un pointeur vers l'endroit où est stockée la vraie valeur de la variable,
+et à chaque lecture / écriture de la variable, on utilise (get-closure-cell-value <cl-cell>) à la place.
+Ceci doit s'effectuer après l'expansion de macros, sinon on risque de louper des noms de variable capturées écrits par les macros.
+Chaque lambda capturant des variables est ensuite modifié de manière à prendre les closure-cell des variables capturées en paramètre.
+Il est "emballé" par une sorte de forme spéciale "closure", qui contient la liste des closure-cell à passer en paramètres à la lambda.
+Il n'y a alors plus de closures dans le sens où toutes les variables capturées le sont explicitement, et sont passées en paramètre.
+On peut donc "sortir" toutes les closures de leur environnement englobant, en les transformant en defuns nommés avec un symbole unique
+généré avec make-symbol. La lambda elle-même est alors remplacée par (closure symbole-unique-du-defun closure-cell*).
+
+TODO : revoir les choix d'implémentation des closures après une nuit de someil...
+Le but est de ne plus avoir aucun lambda imbriqué dans quoi que ce soit
+(tous les lambdas doivent être au top-level, juste emballés par un truc qui les nomme).
+
+;; Implémentation des let, let*, flet, labels, macrolet, ...
+Vu que tous les lambda ont été ramenés au top-level, il n'y a plus de capture de variables.
+Les let sont donc :
+ - À l'intérieur d'un lambda, quelque part
+ - À l'intérieur d'un autre let qui est au top-level
+ - À l'intérieur d'un progn qui est au top-level
+ - Directement au top-level
+Les trois derniers cas peuvent être ramenés au premier en les emballant avec un lambda sans paramètres
+On peut alors "applatir" tous les let imbriqués dans un lambda dans la liste de paramètres du lambda.
+
+Au top-level, on aura donc uniquement des lambda nommés, avec ou sans paramètres, qui ne contiendront ni lambda ni aucune forme de let.
+Il n'y aura plus de macros.
+Plus de block ni tagbody, donc pas de liaison lexicale à ce niveau.
+
+Voici la liste des special-form.
+block                   OK
+catch                   OK
+declare                 -- ?
+eval-when              *OK Avant/pendant macro-expansion
+flet                   *OK
+function                -- ?
+generic-flet            ~~ Non implémenté
+generic-labels          ~~ Non implémenté
+go                      OK
+if                      -- À compiler
+labels                 *OK
+let                    *OK
+let*                   *OK
+macrolet               *OK
+multiple-value-call     ~~ Non implémenté
+multiple-value-prog1    ~~ Non implémenté (mais le serait avec une macro)
+progn                  *OK (un seul géant qui représente le top-level)
+progv                   ~~ Non implémenté
+quote                   -- À compiler
+return-from             OK
+setq                    -- À compiler
+symbol-macrolet         ~~ Non implémenté (peut-être ?)
+tagbody                 OK
+the                     ~~ Non implémenté, transformé ainsi : (the type form) => form
+throw                   OK
+unwind-protect          -- À compiler (ou bien macro-expansé en termes de "asm")
+with-added-methors      ~~ Non implémenté
+
+Les "formes spéciales du compilo" suivantes ont été rajoutées :
+asm                     -- À compiler
+unwind                  -- À compiler (ou bien macro-expansé en termes de "asm")
+closure                 -- À compiler
++ les appels de lambdas nommés. -- À compiler
+
+;; Implémentation des macros et de eval-when
+Lors de la compilation d'un fichier, son top-level est traversé de la manière suivante :
+On crée une instance de compiler-meval, un mini-meval qui renvoie toujours
+un cons de la valeur de retour et de son état, pour qu'on puisse le rappeler.
+compiler-meval transforme le eval-when en progn si sa situation contient :execute, en nil sinon.
+
+NOTE : lorsqu'on rencontre la macro declaim au top-level, la proclamation est prise en compte.
+
+- Si on rencontre EVAL-WHEN,
+  - Au top-level,
+    - Pour chaque form du body,
+      - Si la situation contient :compile-toplevel, le form est évalué dans compiler-meval.
+      - Si la situation contient :load-toplevel, le form est compilé (après évaluation dans compiler-meval s'il y a lieu).
+      - Lorsqu'un eval-when au top-level contient des eval-when directement sous lui, ils sont traités comme s'ils étaient directement au top-level.
+  - Ailleurs
+    - Si la situation contient :load-toplevel, le eval-when est remplacé par son body (TODO : À VÉRIVFIER !).
+- Si on rencontre un defmacro
+  - On demande à compiler-meval de l'exécuter. TODO : doit-on le faire uniquement au top-level ?.
+- Si on rencontre un macrolet
+  - On fait une copie de l'état de compiler-meval
+  - On lui demande d'exécuter les définitions
+  - On évalue le body avec ce nouvel état
+  - On continue avec l'ancien état
+- Si on gère le symbol-macrolet
+  - Le fonctionnement est le même que pour le macrolet
+  - Lorsqu'on rencontre un symbole, on regarde s'il a une définition de type symbol-macrolet
+- Si on rencontre une macro définie dans l'environnement de compiler-meval,
+  1) On demande à compiler-meval d'expanser la macro sur un niveau.
+  2) On re-lance la transformation (eval-when / defmacro / appel de macro / ...) sur le résultat s'il y a a eu expansion.
+- S'occuper du cas du lambda et des autres mot-clés bizarres (ne pas faire de macro-expansion dessus).
+- Dans les autres cas, on transforme récursivement l'expression.
+
+;; Comportement des variables globales et spéciales
+Lorsqu'une variable est utilisée mais ne correspond à aucune liaison (établie par let, …), cette utilisation fait référence
+à une liaison "globale" de cette variable (autrement dit, la valeur est partagée entre toutes les utilisations sans liaison).
+Par défaut, une variable globale est "unbound", et n'a donc pas de valeur. La lecture d'une variable unbound est une erreur.
+x
+=> erreur
+(defun bar () x)
+(bar)
+=> erreur
+(setq x 3)
+(bar)
+=> 3
+
+Lorsqu'une variable est déclarée localement spéciale, avec (declare (special nom-de-variable)) au début d'un defun, d'un let etc.,
+la valeur de la variable est alors la même que la valeur globale.
+Ce comportement spécial s'applique là où la variable est dans la portée lexicale de la forme spéciale englobant le declare (donc uniquement dans le defun, let, …).
+
+(defun baz () y)
+(let ((y 3)) (let ((z 1)) (declare (special y)) (setq y 42) (baz)))
+=> 42 ;; Bien que y soit une liaison lexicale à cause du (let ((y 3)), le (special y) le transforme en variable globale.
+y
+=> 42
+
+Si la forme spéciale englobante devait créer une liaison lecicale pour cette variable, elle ne le fait pas, mais à la place,
+ - la valeur globale d'origine de la variable est sauvegardée,
+ - sa valeur globale est modifiée avec la nouvelle valeur (paramètre effectif pour un defun, valeur de droite pour un let, ...)
+ - La variable devient boundp si elle ne l'était pas déjà
+ - le corps est exécuté, avec la variable partageant sa valeur avec la varaible globale
+ - la valeur d'origine de la variable globale est restaurée.
+ - Si la valeur était unbound, elle redevient unbound.
+
+(defun quux () (print (boundp 'w)) w)
+(boundp 'w)
+=> NIL
+(quux)
+=> erreur
+(let ((w 3)) (declare (special w)) (print (boundp 'w)) (quux))
+=> T ;; boundp
+=> T ;; boundp
+=> 3
+(boundp 'w)
+(quux)
+=> erreur ;; La valeur est bien restaurée.
+
+Lorsqu'on effectue un (defvar var val), var devient globalement spéciale : toutes les utilisations de var pointent vers la même valeur,
+y compris les utilisations effectuées avant le defvar.
+(defun foo1 () var)
+(defun foo2 () (let ((var 4)) (print var) (foo1)))
+var
+=> erreur
+(foo1)
+=> erreur
+(foo2)
+=> 4
+=> erreur
+(defvar var 123)
+var
+=> 123
+(foo1)
+=> 123
+(foo2)
+=> 4
+=> 4
+
+Lors du defvar, si la variable est boundp, sa valeur était conservée, sinon sa valeur globale devient la valeur spécifiée par le defvar.
+Notemment, si le defvar apparaît à l'intérieur d'un let-special qui rend la variable boundp locallement, sa valeur globale sera restaurée à unbound à la sortie du let.
+(defun get-1 () not-boundp)
+(defun get-2 () is-boundp)
+(defun get-3 () locally-boundp)
+(defun getlet-1 () (let ((not-boundp 123))     (get-1)))
+(defun getlet-2 () (let ((is-boundp 123))      (get-2)))
+(defun getlet-3 () (let ((locally-boundp 123)) (get-3)))
+(setq is-boundp 42)
+(get-1)    => error ;; not-boundp
+(get-2)    => 42    ;; is-boundp
+(get-3)    => error ;; locally-boundp
+(getlet-1) => error ;; not-boundp
+(getlet-2) => 42    ;; is-boundp
+(getlet-3) => error ;; locally-boundp
+
+(defvar not-boundp 3)
+(defvar is-boundp  3)
+(let ((locally-boundp 42))
+  (declare (special locally-boundp))
+  (defvar locally-boundp 3))
+(get-1)    => 3     ;; not-boundp
+(get-2)    => 42    ;; is-boundp
+(get-3)    => error ;; locally-boundp
+;; La variable est maintenant spéciale partout :
+(getlet-1) => 123   ;; not-boundp
+(getlet-2) => 123   ;; is-boundp
+(getlet-3) => 123   ;; locally-boundp
+
+;; Implémentation des variables globales et spéciales
+
+Pour les mêmes raisons de santé d'esprit et d'efficacité et d'alignement des planètes que pour la redéclaration de fonctions en macros, nous ne supporterons pas la redéclaration
+de variables non spéciales en spéciales. Ainsi, si un defvar apparaît *après* des utilisations non spéciales de la variable, ces utilisations resteront non spéciales.
+
+Lorsqu'une variable est détectée comme étant spéciale (soit globalement, avec defvar, soit localement, avec declare), sa valeur est stockée dans une global-cell,
+qui ressemble comme deux goutes d'eau à une closure-cell, et toutes ces utilisations passent par la globla-cell, comme pour les variables capturées.
+On est obligé d'avoir ce niveau d'indirection pour les mêmes raisons que pour le closure-cell.
+La différence avec une closure-cell est qu'il n'y a qu'une seule global-cell par variable, qui est créée à la compilation.
+De même, l'utilisation globale d'une variable de manière globale est remplacée par une référence à sa global-cell.
+De plus, les formes spéciales qui devaient créer une liaison locale sont transformées comme suit :
+(let ((x 3)) (declare (special x)) (setq x 42) x)
+Est transformé en :
+== En-tête
+[global-cell x]
+#<unbound>
+== Code
+[push [get-global-cell-value x]]
+[set-global-cell-value x 3]
+[set-global-cell-value x 42]
+[get-global-cell-value x]
+[set-global-cell-value x [pop]]
+
+|#

implementation/mini-meval.lisp

@@ -0,0 +1,238 @@
+(load "match")
+(load "util")
+
+(defun slice-up-lambda-list (lambda-list)
+  (match-automaton lambda-list fixed
+                   (fixed    accept)
+                   (fixed    optional &optional)
+                   (fixed    rest     &rest)
+                   (fixed    key      &key)
+                   (fixed    aux      &aux)
+                   (fixed    reject   $&)
+                   (fixed    fixed    (:var . $$) var)
+                   (optional accept)
+                   (optional rest     &rest)
+                   (optional key      &key)
+                   (optional aux      &aux)
+                   (optional reject   $&)
+                   (optional optional (:var . $$) `(,var nil nil))
+                   (optional optional (:var $$ :default _? :svar $$?) `(,var ,(car default) ,(car svar)))
+                   (rest     reject   $&)
+                   (rest     rest2    (:var . $$) `(,var))
+                   (rest2    accept)
+                   (rest2    key      &key)
+                   (rest2    aux      &aux)
+                   (rest2    reject   $&)
+                   (key      accept)
+                   (key      other    &allow-other-keys t)
+                   (key      aux      &aux)
+                   (key      reject   $&)
+                   (key      key      (:keyword . $k) `(,keyword ,(keyword-to-symbol keyword) nil nil))
+                   (key      key      (:var . $$) `(,var ,var nil nil))
+                   (key      key      (:keyword $$ :default _? :svar $$?) `(,keyword ,(keyword-to-symbol keyword) ,(car default) ,(car svar)))
+                   (key      key      (:var $$ :default _? :svar $$?) `(,var ,var ,(car default) ,(car svar)))
+                   (key      key      ((:keyword $k :var $$) :default _? :svar $$?) `(,keyword ,var ,(car default) ,(car svar)))
+                   (other    accept)
+                   (other    aux      &aux)
+                   (other    reject   $&)
+                   (aux      accept)
+                   (aux      reject   $&)
+                   (aux      aux      (:var . $$) `(,var nil))
+                   (aux      aux      (:var $$ :default _?) `(,var ,(car default)))
+                   (reject (error "slice-up-lambda-list : ~w ne peut être ici." last-element))))
+
+;; Exemples :
+;; (slice-up-lambda-list '(a b &optional u &rest c &key ((:foo bar)) :quux (:baz 'glop) &aux x))
+;; (slice-up-lambda-list '(a b &rest))
+;; (slice-up-lambda-list '(a b))
+
+(declaim (ftype function mini-meval)) ;; récursion mutuelle mini-meval-params / mini-meval
+(defun mini-meval-params (params global local fixed optional rest key other aux)
+  (if fixed
+      (if (endp params)
+          (error "mini-meval-params : not enough parameters !")
+          (mini-meval-params (cdr params) global (acons (car fixed) (car params) local) (cdr fixed) optional rest key other aux))
+      (if optional
+          (let* ((var (caar optional))
+                 (value (if (endp params)
+                            (mini-meval (cadar optional) global local)
+                            (car params)))
+                 (svar (caddar optional))
+                 (new-local (acons var value local))
+                 (new-local-2 (if svar
+                                  (acons svar (endp params) new-local)
+                                  new-local)))
+            (mini-meval-params (cdr params) global new-local-2 nil (cdr optional) rest key other aux))
+          (if rest
+              (mini-meval-params params global (acons (car rest) params local) nil nil nil key other aux)
+              ;; TODO : finir d'implémenter &key &allow-other-keys &aux (et relire CLTL).
+              local))))
+;              (if key
+;                  (let* ((keyword (first (car key)))
+;                         (var (second (car key)))
+;                         (maybe-val (member keyword params))
+;                         (maybe-val-2 (if maybe-val
+;                                          (if (n-consp 2 maybe-val)
+;                                              maybe-val
+;                                              (error "mini-meval-params : Nombre de paramètres impair alors qu'il y a &key."))))
+;                         (svar (fourth (car key)))
+;                         (new-local (acons var (if maybe-val-2
+;                                                   (cadr maybe-val-2)
+;                                                   (mini-meval (third (car key)) global local))
+;                                           local))
+;                         (new-local-2 (if svar
+;                                          (acons svar (not (not (maybe-val-2))) new-local)
+;                                          new-local)))
+;                    (mini-meval-params params global new-local-2 nil nil nil (cdr key) aux)
+
+(defun mini-meval-get-params-from-real (etat-global etat-local lambda-list effective-parameters)
+  "Lambda-list doit être déjà sliced."
+  (apply #'mini-meval-params effective-parameters etat-global etat-local
+         (cdr (assoc 'fixed    lambda-list))
+         (cdr (assoc 'optional lambda-list))
+         (cdr (assoc 'rest     lambda-list))
+         (cdr (assoc 'key      lambda-list))
+         (cdr (assoc 'other    lambda-list))
+         (cdr (assoc 'aux      lambda-list))))
+
+#|
+Mini-meval est un meval très simple destiné à évaluer les macros et les autres directives avec eval-when :compile-toplevel.
+
+;; Fonctionnement de mini-meval
+Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il faut donc qu'il puisse maintenir son état entre les appels.
+|#
+(defun mini-meval (expr &optional etat-global etat-local)
+  #|
+  L'algorithme d'évaluation est très simple et suit le schéma donné dans CLTL 5.1.3 :
+    1) Si l'expression est une forme spéciale, on la traite de manière particulière
+    2) Si l'expression est un appel de macro, on évalue le corps de la macro avec les paramètres tels quels (non évalués),
+       puis on remplace l'appel par son résutlat, et on évalue ce résultat.
+    3) Sinon, c'est un appel de fonction.
+  Pour permettre au code de bas niveau de redéfinir les formes spéciales, on fera d'abord la macro-expansion (étape 2).
+  |#
+  
+  (cond-match
+   expr
+   #| 2) Cas des macros |#
+   ((:name $ :params _*)
+    (let ((definition (assoc* `(,name macro) #'equal etat-local etat-global)))
+      (if definition
+          #| - Si on a une fonction de ce nom dans l'état-local ou dans l'etat-global, on l'exécute. |#
+          (apply (cdr definition) (mapcar (lambda (x) (mini-meval x etat-global etat-local)) params))
+          (else))))
+   #| 1) Cas des formes spéciales |#
+   ((eval-when :situations ($*) :body _*)
+    (if (member :execute situations)
+        (mini-meval body etat-global etat-local)
+        nil))
+   ((flet ((:name $ :lambda-list @ :fbody _*)*) :body _*)
+    (mini-meval `(progn ,body)
+                etat-global
+                (reduce* etat-local (lambda (new-etat-local name lambda-list fbody)
+                                      (acons (cons name 'function)
+                                             (mini-meval `(lamdba ,lambda-list ,@fbody) etat-global etat-local)
+                                             new-etat-local))
+                         name lambda-list fbody)))
+   ((labels ((:name $ :lambda-list @ :fbody _*)*) :body _*)
+    (let* ((new-bindings (reduce* nil (lambda (new-bindings name) `(((,name . 'function) . nil) . ,new-bindings))
+                                  name))
+           (new-etat-local (append new-bindings etat-local)))
+      (mapcar (lambda (name lambda-list fbody)
+                ;; On fait un assoc / setf dans new-bindings, qui ne contient que les fonctions qu'on vient juste d'ajouter, pour éviter
+                ;; le risque inexistant de faire une mutation dans etat-local.
+                ;; TODO : vérifier que ça marche.
+                (assoc-set `(,name 'function)
+                      (mini-meval `(lambda ,lambda-list ,@fbody) new-etat-local)
+                      new-bindings
+                      #'equal))
+              name lambda-list fbody)
+      (mini-meval `(progn ,body) etat-global new-etat-local)))
+   ((let ((:name $ :value _)*) :body _*)
+    (mini-meval `(progn ,body)
+                etat-global
+                (reduce* etat-local (lambda (new-etat-local name value)
+                                      (acons (cons name 'variable)
+                                             (mini-meval value etat-global etat-local)
+                                             new-etat-local))
+                         name value)))
+   ((let* ((:name $ :value _)*) :body _*)
+    (mini-meval `(progn ,body)
+                etat-global
+                (reduce* etat-local (lambda (new-etat-local name value)
+                                      (acons (cons name 'variable)
+                                             ;; Comme let sauf new-etat-local au lieu de etat-local ici.
+                                             (mini-meval value etat-global new-etat-local)
+                                             new-etat-local))
+                         name value)))
+   ((macrolet ((:name $ :lambda-list @ :mbody _*)*) :body _*)
+    (mini-meval `(progn ,body)
+                etat-global
+                (reduce* etat-local (lambda (new-etat-local name lambda-list mbody)
+                                      (acons (cons name 'macro)
+                                             ;; comme le flet sauf nil au lieu de new-etat-local
+                                             ;; CLTL 7.5 :
+                                             ;; The precise rule is that the macro-expansion functions defined
+                                             ;; by macrolet are defined in the global environment; lexically
+                                             ;; scoped entities that would ordinarily be lexically apparent
+                                             ;; are not visible within the expansion functions.
+                                             (mini-meval `(lambda ,lambda-list ,@mbody) etat-global nil)
+                                             new-etat-local))
+                         name lambda-list mbody)))
+   ((progn :body _*)
+    (cdr (last (mapcar (lambda (expr) (mini-meval expr etat-global etat-local))
+                       body))))
+   ((if :condition _ :si-vrai _ :si-faux _?)
+    (if (mini-meval condition etat-global etat-local)
+        (mini-meval si-vrai etat-global etat-local)
+        (if si-faux
+            (mini-meval (car si-faux) etat-global etat-local)
+            nil)))
+   ((lambda :lambda-list @ :body _*)
+    (let ((sliced-lambda-list (slice-up-lambda-list lambda-list)))
+      (lambda (&rest effective-parameters)
+        (mini-meval body
+                    etat-global
+                    (mini-meval-get-params-from-real etat-global etat-local sliced-lambda-list effective-parameters)))))
+   ((defun :name $ :lambda-list @ :body _*)
+    (assoc-set `(,name 'function)
+          (mini-meval `(lambda ,lambda-list ,@body) etat-global etat-local)
+          etat-global
+          #'equal)
+    name)
+   ((defmacro :name $ :lambda-list @ :body _*)
+    (assoc-set `(,name 'macro)
+          (mini-meval `(lambda ,lambda-list ,@body) etat-global etat-local)
+          etat-global
+          #'equal)
+    name)
+   ((defvar :name $ :value _)
+    (assoc-set `(,name 'variable)
+          (mini-meval value etat-global etat-local)
+          etat-global
+          #'equal)
+    name)
+   ((setf/setq)
+    )
+   #| Traitement des appels de fonction |#
+   ((:lambda (lambda @ _*) :params _*)
+    #| - Si c'est une fonction anonyme, on l'exécute. |#
+    (apply (mini-meval lambda etat-global etat-local) params))
+   ((:name $ :params _*)
+    (let ((definition (assoc* `(,name function) #'equal etat-local etat-global)))
+      (if definition
+          #| - Si on a une fonction de ce nom dans l'état-local ou dans l'etat-global, on l'exécute. |#
+          (apply (cdr definition) (mapcar (lambda (x) (mini-meval x etat-global etat-local)) params))
+          (error "mini-meval : undefined function : ~w" name))))
+   ((:name . $$)
+    (let ((definition (assoc* `(,name variable) #'equal etat-local etat-global)))
+      (if definition
+          (cdr definition)
+          (error "mini-meval : undefined variable : ~w" name))))
+   ((:num . (? numberp))
+    num)
+   ((:str . (? stringp))
+    str)
+   ((quote :val _)
+    val)
+   (()
+    nil)))

match.lisp

@@ -16,6 +16,9 @@
 ;; (a . rest)          (and (match a (car expr)) (match rest (cdr expr)))
 ;; ()                  (null expr)
 ;; $                   (and (atom expr) (not (null expr)))
+;; $$                  (symbolp expr)
+;; $k                  (keywordp expr)
+;; $&                  (and (symbolp expr) (member expr '(&optional &rest &key &allow-other-keys &aux)))
 ;; @                   liste propre : (and (listp expr) (match @ (cdr expr)))
 ;; @.                  cons : (consp expr)
 ;; _                   t
@@ -39,7 +42,7 @@
                   ((eq (car pred) 'function) pred)
                   ((eq (car pred) 'lambda)   pred)
                   (t
-                   `(lambda (x) ,pred))))
+                   `(lambda (x) x ,pred))))
           pattern))
 
 (defun pattern-match-do-lambdas-1 (pattern)
@@ -50,7 +53,7 @@
              ,(if (second pattern)
                   (let ((?-clause (cdr (third pattern)))
                         (type '_))
-                    (when (and (consp ?-clause) (member (car ?-clause) '(nil _ $ @ @.)))
+                    (when (and (consp ?-clause) (member (car ?-clause) '(nil _ $ $$ $k $& @ @.)))
                       (setq type (car ?-clause))
                       (setq ?-clause (cdr ?-clause)))
                     ;; TODO : (? or foo (? _ and bar baz) (? $ and quux))
@@ -316,7 +319,10 @@
                  (or (when match
                        (let ((match-rest (pattern-match rest (cdr expr))))
                          (when match-rest
-                           (append match match-rest)))) ;; TODO : vérifier qu'on n'a pas besoin d'un make-empty-matches en cas de non-match de sous-trucs. (normalement non)
+                           ;; Attention, les trois lignes suivantes ont été modifiées sans que je comprenne vraiement les manipulations...
+                           (append-car-cdr-not-nil
+                            (append-captures match (cons (acons-capture capture-name expr (make-empty-matches pattern))
+                                                         match-rest))))))
                      (let ((match-only-rest (pattern-match rest expr)))
                        (when match-only-rest
                          (append (acons-capture capture-name expr (make-empty-matches pattern))
@@ -351,6 +357,18 @@
                (when (and (atom expr)
                           (not (null expr)))
                  (acons-capture capture-name expr nil)))
+              ;; $$
+              ((eq '$$ pattern)
+               (when (symbolp expr)
+                 (acons-capture capture-name expr nil)))
+              ;; $k
+              ((eq '$k pattern)
+               (when (keywordp expr)
+                 (acons-capture capture-name expr nil)))
+              ;; $&
+              ((eq '$& pattern)
+               (when (and (symbolp expr) (member expr '(&optional &rest &key &allow-other-keys &aux)))
+                 (acons-capture capture-name expr nil)))
               ;; @
               ((eq '@ pattern)
                (when (propper-list-p expr)
@@ -375,33 +393,49 @@
        pattern))))
 
 (defmacro real-match (pattern expr body &optional else-clause)
-  (let* ((result-sym (make-symbol "result"))
+  (let* ((result-sym (make-symbol "RESULT"))
-         (pattern-sym (make-symbol "pattern"))
+         (result-of-if-sym (make-symbol "RESULT-OF-IF"))
+         (pattern-sym (make-symbol "PATTERN"))
+         (else-sym (make-symbol "ELSE"))
          (pattern-preproc (pattern-match-preprocess-capture
                            (pattern-match-preprocess-multi
                             pattern)))
          (capture-names (mapcar #'car (make-empty-matches pattern-preproc))))
     `(let* ((,pattern-sym (pattern-match-do-lambdas ,pattern-preproc))
-            (,result-sym (pattern-match ,pattern-sym ,expr)))
+            (,result-sym (pattern-match ,pattern-sym ,expr))
-       ;; Filtrage des captures nommées nil.
+            (,result-of-if-sym
-       (if ,result-sym
+             (if ,result-sym
-           ,@(if body
+                 ;; Si le match a été effectué avec succès
-                 `((let ,(mapcar (lambda (x)
+                 ,@(if body
-                                   `(,x (cdr (assoc ',x ,result-sym))))
+                       ;; Si on a un body
-                                 capture-names)
+                       ;; On bind les variables correspondant aux noms de capture
-                     ;; "utilisation" des variables pour éviter les warning unused variable.
+                       `((let ,(mapcar (lambda (x) `(,x (cdr (assoc ',x ,result-sym))))
-                     ,@capture-names
+                                       capture-names)
-                     ,@body))
+                           ;; "utilisation" des variables pour éviter les warning unused variable.
-                 (if capture-names
+                           ,@capture-names
-                     `((remove nil ,result-sym :key #'car))
+                           ;; On définit la fonction "else" qui produit le "code secret" permettant d'exécuter le else.
-                     `(t)))
+                           (labels ((else () ',else-sym))
-           ,else-clause))))
+                             ;; On exécute le body
+                             ,@body)))
+                       ;; S'il n'y a pas de body, on renvoie l'alist des captures s'il y en a ou T sinon.
+                       (if capture-names
+                           `((remove nil ,result-sym :key #'car))
+                           `(t)))
+                 ;; Si on ne match pas, on renvoie le "code secret" permettant d'exécuter le else.
+                 ',else-sym)))
+       ;; Si le résultat est le "code secret" du else, on fait le else, sinon on renvoie le résultat
+       (if (eq ,result-of-if-sym ',else-sym)
+           ,else-clause
+           ,result-of-if-sym))))
 
 (defmacro match (pattern expr &rest body)
   (if (keywordp pattern)
       `(real-match (,pattern . ,expr) ,(car body) ,(cdr body))
       `(real-match ,pattern ,expr ,body)))
 
+(defmacro if-match (pattern expr body-if body-else)
+  `(real-match ,pattern ,expr (,body-if) ,body-else))
+
 (defmacro cond-match-1 (expr cond-clauses)
   (if (endp cond-clauses)
       'nil
@@ -516,6 +550,117 @@
            (defun ,add-pattern-function (func)
              (setf rules (append rules (list func))))))))
 
+;; Version de match-automaton avec loop :
+;; `(loop
+;;     with ,state = ',initial-state
+;;     with accumulator = nil
+;;     for step = (cond-match ...)
+;;     when (eq state 'accept)
+;;       return (reverse accumulator)
+;;     when (eq state 'reject)
+;;       return nil
+;;     do (setq state (car step)))
+
+#|
+Syntaxe du match-automaton :
+(match-automaton expression initial-state
+                 (stateX stateY [pattern] [code])
+                 (stateX stateY [pattern] [code])
+                 ...)
+Si pattern n'est pas fourni, alors stateY est soit accept ou reject, pour indiquer qu'on accepte ou rejette l'expression si on arrive sur cet état à la fin.
+Si pattern est fourni, cela signifie «Si l'élément courant de l'expression matche avec ce pattern, passer à l'élément suivant et aller dans l'état stateY.».
+Lorsque l'expression est acceptée, pattern-match renvoie une liste associative ((state1 élément-1 ... élément-n) (state2 e1..eN) ...)
+Les éléments à droite de chaque nom d'état sont obtenus de la manière suivante :
+  Si code est fourni, il est exécuté, et sa valeur de retour est ajoutée à la fin de la liste correspondant à stateX (l'état de départ).
+  Si code n'est pas fourni, rien n'est ajouté à cette liste.
+Lorsqu'on est sur un certain état, chaque transition partant de cet état est testée dans l'ordre d'écriture, et la première qui matche est choisie.
+
+De plus, il est possible de spécifier des clauses spéciales, au lieu des (stateX stateY [pattern] [code]) :
+ - (initial code ...), qui exécute le code avant de démarrer (pas très utile...)
+ - (accept code ...), qui exécute le code dans le cas où l'expression est acceptée. La valeur renvoyée par ce code sera la valeur de retour de match-automaton.
+                      Dans cette clause, on peut accéder à la valeur qui aurait dû être renvoyée via la variable return-value.
+ - (reject code ...), qui exécute le code dans le cas où l'expression est rejetée. La valeur renvoyée par ce code sera la valeur de retour de match-automaton.
+                      Dans cette clause, le dernier élément considéré est stocké dans last-element.
+                      Cet élément est celui qui a causé le reject, ou nil si on est au début de la liste, ou nil si on est à la fin de la liste sans accept.
+                      ;;De même, le dernier état courant est dans last-state.
+
+Il peut y avoir plusieurs initial, accept et reject, auquel cas tous sont exécutés dans l'ordre d'écriture, et sont concaténés dans un progn,
+donc seule la valeur de la dernière expression de la dernière clause est renvoyée.
+|#
+
+;; ATTENTION, par excès de flemme, match-automaton ne supporte pas la syntax
+;; (macro :var atom expr code)
+;; ATTENTION, j'ai renoncé à rendre ce code lisible.
+(defun match--grouped-transition-to-progns (grouped-transition)
+  ;; On remet to, pattern et code bout à bout (c'est tout du code)
+  (mapcar (lambda (x) `(progn ,(car x) ,@(cadr x) ,@(caddr x)))
+          (cdr grouped-transition)))
+
+(defmacro match-automaton (expr initial-state &rest rules)
+  (match ((:from $$ :to _ :pattern _? :code _*) *) rules
+         (let ((storage (mapcar (lambda (s) (cons s (make-symbol (format nil "STORAGE-~a" (string s))))) (remove-duplicates from)))
+               (expr-sym (make-symbol "EXPR"))
+               (block-sym (make-symbol "BLOCK"))
+               (grouped-transitions (group (mapcar #'list from to pattern code)))
+               (last-state-sym (make-symbol "LAST-STATE"))
+               (last-element-sym (make-symbol "LAST-ELEMENT")))
+           `(let (,@(mapcar (lambda (s) `(,(cdr s) nil)) storage)
+                  (,expr-sym ,expr)
+                  (,last-state-sym 'initial)
+                  (,last-element-sym nil))
+              (block ,block-sym
+                (tagbody
+                 initial
+                   (progn ,(match--grouped-transition-to-progns (assoc 'initial grouped-transitions)))
+                   (go ,initial-state)
+                 accept
+                   (let ((return-value (list ,@(mapcar (lambda (s) `(cons ',(car s) (reverse ,(cdr s)))) storage))))
+                     return-value
+                     (return-from ,block-sym
+                       (progn return-value
+                              ,@(match--grouped-transition-to-progns (assoc 'accept grouped-transitions)))))
+                 reject
+                   (return-from ,block-sym
+                     (let ((last-element ,last-element-sym)
+                           (last-state ,last-state-sym))
+                       last-element
+                       last-state
+                       (progn nil
+                              ,@(match--grouped-transition-to-progns (assoc 'reject grouped-transitions)))))
+                   ;; On va générer ceci :
+                   ;; state1
+                   ;;   (cond-match ... (go state2) ... (go state1) ...)
+                   ;; state2
+                   ;;   (cond-match ... (go staten) ... (go reject) ...)
+                   ;; staten
+                   ;;   (cond-match ... (go accept) ... (go state1) ...)))
+                   ,@(loop
+                        for (from . transitions) in grouped-transitions
+                        unless (member from '(initial accept reject))
+                          collect from
+                          and collect `(setq ,last-state-sym ',from)
+                          and collect `(setq ,last-element-sym (car ,expr-sym))
+                          and collect `(print ',from)
+                          and if (member nil transitions :key #'second)
+                            collect `(when (endp ,expr-sym) (print 'auto-accept) (go accept)) ;; TODO : aller à l'état désigné par la dernière transition "finale". + syntaxe (stateX code) => exécute le code à chaque fois qu'on rentre dans stateX.
+                          else
+                            collect `(when (endp ,expr-sym) (print 'auto-reject) (go reject))
+                          end
+                          and collect `(cond-match (car ,expr-sym)
+                                                   ,@(loop
+                                                        for (to pattern code) in transitions
+                                                        when pattern
+                                                          if code
+                                                            collect `(,@pattern
+                                                                    (push (progn ,@code) ,(cdr (assoc from storage)))
+                                                                    (setq ,expr-sym (cdr ,expr-sym))
+                                                                    (go ,to))
+                                                          else
+                                                            collect `(,@pattern
+                                                                      (setq ,expr-sym (cdr ,expr-sym))
+                                                                      (go ,to)))
+                                                   (_ (go reject))))))))))
+
 (load "test-unitaire")
 (erase-tests match)
 

meval.lisp

@@ -102,7 +102,7 @@ retourne la liste de leurs valeurs"
 d’arguments dans un certain environnement."
   (match (:nil :lclosure :size (? integerp) :rest (? integerp)? :body _*) lclosure
          (meval lclosure
-                (make-env size args env rest))))
+                (make-env size args env (car rest)))))
 
 (defun msetf (place val env)
   (let ((sub-env (get-env-num (first place) env)))
@@ -138,12 +138,12 @@ d’arguments dans un certain environnement."
                (let ((name (meval macro-name env)))
                  (setf (get name :defmacro) closure)
                  name))
-              ((:nil :mcall :func-name (? (get x :defun)) :params _*)
+              ((:nil :mcall :func-name (? $$ (get x :defun)) :params _*)
                (let ((values (meval-args params env)))
                  (meval-lambda (car (get func-name :defun))
                                values
                                (make-env (length values) values env))))
-              ((:nil :mcall :macro-name (? (get x :defmacro)) :params _*)
+              ((:nil :mcall :macro-name (? $$ (get x :defmacro)) :params _*)
                (let ((values (meval-args params env)))
                  (meval (lisp2li (meval-lambda (car (get macro-name :defmacro))
                                params
@@ -193,7 +193,7 @@ d’arguments dans un certain environnement."
 
 (deftest (meval :cvar)
   (meval '(:cvar 1 2) #(#(() 7 8) 4 5 6)) 
-  8)
+  5)
 
 (deftest (meval :call)
   (meval '(:call + (:const . 3) (:cvar 0 1)) #(() 4 5 6))

test-unitaire.lisp

@@ -101,10 +101,10 @@
 (defun real-run-tests (module-name from)
   (if (second from)
       (progn
-        (format t "~&~%-~{ ~a~}~&    [Déjà vu]~&" (or module-name '("all-tests")))
+        (format t "~&~%-~{ ~w~}~&    [Déjà vu]~&" (or module-name '(all-tests)))
         t)
       (progn
-        (format t "~&~%>~{ ~a~}~&" (or module-name '("all-tests")))
+        (format t "~&~%>~{ ~w~}~&" (or module-name '("all-tests")))
         (setf (second from) t) ;; marquer comme exécuté.
         (let ((nb-fail (count-if-not #'funcall (reverse (fourth from)))))
           (if (= nb-fail 0)
@@ -139,14 +139,6 @@
       (equalp foo #(a b (1 #(2 4 6) 3) c)))
   t #'booleq)
 
-(deftest (test-unitaire copy-all)
-    (let* ((foo #(a x (1 #(2 4 7) 5) c))
-           (copy-of-foo (copy-all foo)))
-      copy-of-foo
-      (setf (aref (cadr (aref foo 2)) 1) (cons 'MODIFIED (random 42)))
-      (equalp foo #(a x (1 #(2 4 7) 5) c)))
-  nil #'booleq)
-
 ;;; Exemples d'utilisation.
 
 ;; (erase-tests (a sub-1))

util.lisp

@@ -10,10 +10,10 @@
 ;; (loop ......) lire la doc...
 ;; (subst new old tree) remplace old par new dans tree.
 
-(defmacro aset (k v alist)
+(defmacro assoc-set (k v alist &optional (compare #'eq))
   `(let ((my-k ,k)
          (my-v ,v))
-     (let ((association (assoc my-k ,alist)))
+     (let ((association (assoc my-k ,alist :key ,compare)))
        (if association
            (setf (cdr association) my-v)
            (push (cons my-k my-v) ,alist)))))
@@ -70,11 +70,6 @@
            collect line
            finally (close fd)))))
 
-(defun propper-list-p (l)
-  (or (null l)
-	  (and (consp l)
-		   (propper-list-p (cdr l)))))
-
 (defun m-macroexpand-1 (macro)
   ;; TODO : not implemented yet m-macroexpand-1
   macro ;; Pour éviter le unused variable.
@@ -125,3 +120,53 @@
     (t
      (warn "copy-all : Je ne sais pas copier ~w" data)
      data)))
+
+(defun flatten (lst &optional rest result)
+  (if (endp lst)
+      (if (endp rest)
+          (reverse result)
+          (flatten (car rest) (cdr rest) result))
+      (if (listp (car lst))
+          (flatten (car lst) (cons (cdr lst) rest) result)
+          (flatten (cdr lst) rest (cons (car lst) result)))))
+
+(defun mapcar-append (append function &rest lists)
+  (cond ((null lists)
+         append)
+        ((member nil lists)
+         append)
+        (t
+         (cons (apply function (mapcar #'car lists))
+               (apply #'mapcar-append append function (mapcar #'cdr lists))))))
+
+(defun reduce* (initial function &rest lists)
+  (if (or (null lists) (member nil lists))
+      initial
+      (apply #'reduce* (apply function initial (mapcar #'car lists))
+             function
+             (mapcar #'cdr lists))))
+
+(defun assoc* (item compare &rest alists)
+  (if (not (functionp compare))
+      (apply #'assoc* item #'eq compare alists)
+      (if (endp alists)
+          nil
+          (or (assoc item (car alists) :test compare)
+              (apply #'assoc* item compare (cdr alists))))))
+
+(defun reverse-alist (alist)
+  (mapcar (lambda (x) (cons (car x) (reverse (cdr x))))
+          alist))
+
+(defun group-1 (lst &optional result)
+  "Groupe les éléments d'une lste en fonction de leur premier élément, et renvoie une lste associative"
+  (if (endp lst)
+      result
+      (let ((association (assoc (caar lst) result)))
+        (if association
+            (push (cdar lst) (cdr association))
+            (push (cons (caar lst) (list (cdar lst))) result))
+        (group-1 (cdr lst) result))))
+
+(defun group (lst)
+  (reverse-alist (group-1 lst)))