diff --git a/TODO-Liste b/TODO-Liste index 65f057b..e517889 100644 --- a/TODO-Liste +++ b/TODO-Liste @@ -2,7 +2,8 @@ TODO : - Ajouter la fonction map-case-analysis - Changer les 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, ...). diff --git a/implementation/capture-variables.dia b/implementation/capture-variables.dia new file mode 100644 index 0000000..51b80fa Binary files /dev/null and b/implementation/capture-variables.dia differ diff --git a/implementation/compilation.lisp b/implementation/compilation.lisp new file mode 100644 index 0000000..be7a2f5 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/implementation/lisp2cli.lisp b/implementation/lisp2cli.lisp new file mode 100644 index 0000000..3f54139 --- /dev/null +++ b/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 +=> (# . #) +(setq cl42 (make-closure 42)) +=> 42 +=> 43 +=> (# . #) +;; 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 qui sont accessibles lexicalement sont remplacés par un (unwind ) +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 ) à 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] +# +== 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]] + +|# \ No newline at end of file diff --git a/implementation/mini-meval.lisp b/implementation/mini-meval.lisp new file mode 100644 index 0000000..d2ef194 --- /dev/null +++ b/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))) diff --git a/match.lisp b/match.lisp index 95a5c12..afd46c6 100644 --- a/match.lisp +++ b/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")) - (pattern-sym (make-symbol "pattern")) + (let* ((result-sym (make-symbol "RESULT")) + (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))) - ;; Filtrage des captures nommées nil. - (if ,result-sym - ,@(if body - `((let ,(mapcar (lambda (x) - `(,x (cdr (assoc ',x ,result-sym)))) - capture-names) - ;; "utilisation" des variables pour éviter les warning unused variable. - ,@capture-names - ,@body)) - (if capture-names - `((remove nil ,result-sym :key #'car)) - `(t))) - ,else-clause)))) + (,result-sym (pattern-match ,pattern-sym ,expr)) + (,result-of-if-sym + (if ,result-sym + ;; Si le match a été effectué avec succès + ,@(if body + ;; Si on a un body + ;; On bind les variables correspondant aux noms de capture + `((let ,(mapcar (lambda (x) `(,x (cdr (assoc ',x ,result-sym)))) + capture-names) + ;; "utilisation" des variables pour éviter les warning unused variable. + ,@capture-names + ;; On définit la fonction "else" qui produit le "code secret" permettant d'exécuter le else. + (labels ((else () ',else-sym)) + ;; 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) diff --git a/meval.lisp b/meval.lisp index 5411c15..445cb2a 100644 --- a/meval.lisp +++ b/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)) diff --git a/test-unitaire.lisp b/test-unitaire.lisp index 539367b..444dff7 100644 --- a/test-unitaire.lisp +++ b/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)) diff --git a/util.lisp b/util.lisp index b7df50b..6348471 100644 --- a/util.lisp +++ b/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)))